packages feed

cabal-install 3.4.1.0 → 3.6.0.0

raw patch · 426 files changed

+58923/−59805 lines, 426 filesdep ~Cabaldep ~basedep ~bytestring

Dependency ranges changed: Cabal, base, bytestring

Files

− Distribution/Client/BuildReports/Anonymous.hs 
@@ -1,157 +0,0 @@-{-# LANGUAGE ConstraintKinds   #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Reporting--- Copyright   :  (c) David Waern 2008--- License     :  BSD-like------ Maintainer  :  david.waern@gmail.com--- Stability   :  experimental--- Portability :  portable------ Anonymous build report data structure, printing and parsing----------------------------------------------------------------------------------module Distribution.Client.BuildReports.Anonymous (-    BuildReport(..),-    InstallOutcome(..),-    Outcome(..),--    -- * Constructing and writing reports-    newBuildReport,--    -- * parsing and pretty printing-    parseBuildReport,-    parseBuildReportList,-    showBuildReport,---    showList,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.CabalSpecVersion-import Distribution.Client.BuildReports.Types-import Distribution.Client.Utils              (cabalInstallVersion)-import Distribution.Compiler                  (CompilerId (..))-import Distribution.FieldGrammar-import Distribution.Fields                    (readFields, showFields)-import Distribution.Fields.ParseResult        (ParseResult, parseFatalFailure, runParseResult)-import Distribution.Package                   (PackageIdentifier (..), mkPackageName)-import Distribution.PackageDescription        (FlagAssignment)-import Distribution.Parsec                    (PError (..), zeroPos)-import Distribution.System                    (Arch, OS)--import qualified Distribution.Client.BuildReports.Lens as L-import qualified Distribution.Client.Types             as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))--import qualified Data.ByteString       as BS-import qualified Data.ByteString.Char8 as BS8------------------------------------------------------------------------------------- New----------------------------------------------------------------------------------newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment-    -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport-newBuildReport os' arch' comp pkgid flags deps result =-  BuildReport {-    package               = pkgid,-    os                    = os',-    arch                  = arch',-    compiler              = comp,-    client                = cabalInstallID,-    flagAssignment        = flags,-    dependencies          = deps,-    installOutcome        = convertInstallOutcome,---    cabalVersion          = undefined-    docsOutcome           = convertDocsOutcome,-    testsOutcome          = convertTestsOutcome-  }-  where-    convertInstallOutcome = case result of-      Left  BR.PlanningFailed      -> PlanningFailed-      Left  (BR.DependentFailed p) -> DependencyFailed p-      Left  (BR.DownloadFailed  _) -> DownloadFailed-      Left  (BR.UnpackFailed    _) -> UnpackFailed-      Left  (BR.ConfigureFailed _) -> ConfigureFailed-      Left  (BR.BuildFailed     _) -> BuildFailed-      Left  (BR.TestsFailed     _) -> TestsFailed-      Left  (BR.InstallFailed   _) -> InstallFailed-      Right (BR.BuildResult _ _ _) -> InstallOk-    convertDocsOutcome = case result of-      Left _                                      -> NotTried-      Right (BR.BuildResult BR.DocsNotTried _ _)  -> NotTried-      Right (BR.BuildResult BR.DocsFailed _ _)    -> Failed-      Right (BR.BuildResult BR.DocsOk _ _)        -> Ok-    convertTestsOutcome = case result of-      Left  (BR.TestsFailed _)                    -> Failed-      Left _                                      -> NotTried-      Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried-      Right (BR.BuildResult _ BR.TestsOk _)       -> Ok--cabalInstallID :: PackageIdentifier-cabalInstallID =-  PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion------------------------------------------------------------------------------------ FieldGrammar----------------------------------------------------------------------------------fieldDescrs-    :: ( Applicative (g BuildReport), FieldGrammar c g-       , c (Identity Arch)-       , c (Identity CompilerId)-       , c (Identity FlagAssignment)-       , c (Identity InstallOutcome)-       , c (Identity OS)-       , c (Identity Outcome)-       , c (Identity PackageIdentifier)-       , c (List VCat (Identity PackageIdentifier) PackageIdentifier)-       )-    => g BuildReport BuildReport-fieldDescrs = BuildReport-    <$> uniqueField       "package"                           L.package-    <*> uniqueField       "os"                                L.os-    <*> uniqueField       "arch"                              L.arch-    <*> uniqueField       "compiler"                          L.compiler-    <*> uniqueField       "client"                            L.client-    <*> monoidalField     "flags"                             L.flagAssignment-    <*> monoidalFieldAla  "dependencies"       (alaList VCat) L.dependencies-    <*> uniqueField       "install-outcome"                   L.installOutcome-    <*> uniqueField       "docs-outcome"                      L.docsOutcome-    <*> uniqueField       "tests-outcome"                     L.testsOutcome---- -------------------------------------------------------------------------------- Parsing--parseBuildReport :: BS.ByteString -> Either String BuildReport-parseBuildReport s = case snd $ runParseResult $ parseFields s of-  Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ]-  Right report -> Right report--parseFields :: BS.ByteString -> ParseResult BuildReport-parseFields input = do-  fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input-  case partitionFields fields of-    (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs-    _otherwise    -> parseFatalFailure zeroPos "found sections in BuildReport"--parseBuildReportList :: BS.ByteString -> [BuildReport]-parseBuildReportList str =-  [ report | Right report <- map parseBuildReport (split str) ]--  where-    split :: BS.ByteString -> [BS.ByteString]-    split = filter (not . BS.null) . unfoldr chunk . BS8.lines-    chunk [] = Nothing-    chunk ls = case break BS.null ls of-                 (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)---- -------------------------------------------------------------------------------- Pretty-printing--showBuildReport :: BuildReport -> String-showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs
− Distribution/Client/BuildReports/Lens.hs 
@@ -1,46 +0,0 @@-module Distribution.Client.BuildReports.Lens (-    BuildReport,-    module Distribution.Client.BuildReports.Lens,-) where--import Distribution.Client.Compat.Prelude-import Distribution.Compat.Lens-import Prelude ()--import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome)-import Distribution.Compiler                  (CompilerId)-import Distribution.System                    (Arch, OS)-import Distribution.Types.Flag                (FlagAssignment)-import Distribution.Types.PackageId           (PackageIdentifier)--import qualified Distribution.Client.BuildReports.Types as T--package :: Lens' BuildReport PackageIdentifier-package f s = fmap (\x -> s { T.package = x }) (f (T.package s))--os :: Lens' BuildReport OS-os f s = fmap (\x -> s { T.os = x }) (f (T.os s))--arch :: Lens' BuildReport Arch-arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s))--compiler :: Lens' BuildReport CompilerId-compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s))--client :: Lens' BuildReport PackageIdentifier-client f s = fmap (\x -> s { T.client = x }) (f (T.client s))--flagAssignment :: Lens' BuildReport FlagAssignment-flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s))--dependencies :: Lens' BuildReport [PackageIdentifier]-dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s))--installOutcome :: Lens' BuildReport InstallOutcome-installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s))--docsOutcome :: Lens' BuildReport Outcome-docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s))--testsOutcome :: Lens' BuildReport Outcome-testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s))
− Distribution/Client/BuildReports/Storage.hs 
@@ -1,163 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Reporting--- Copyright   :  (c) David Waern 2008--- License     :  BSD-like------ Maintainer  :  david.waern@gmail.com--- Stability   :  experimental--- Portability :  portable------ Anonymous build report data structure, printing and parsing----------------------------------------------------------------------------------module Distribution.Client.BuildReports.Storage (--    -- * Storing and retrieving build reports-    storeAnonymous,-    storeLocal,---    retrieve,--    -- * 'InstallPlan' support-    fromInstallPlan,-    fromPlanningFailure,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport)-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport--import Distribution.Client.Types-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan-         ( InstallPlan )--import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.SourcePackage--import Distribution.Package-         ( PackageId, packageId )-import Distribution.PackageDescription-         ( FlagAssignment )-import Distribution.Simple.InstallDirs-         ( PathTemplate, fromPathTemplate-         , initialPathTemplateEnv, substPathTemplate )-import Distribution.System-         ( Platform(Platform) )-import Distribution.Compiler-         ( CompilerId(..), CompilerInfo(..)  )-import Distribution.Simple.Utils-         ( equating )--import Data.List.NonEmpty-         ( groupBy )-import qualified Data.List as L-import System.FilePath-         ( (</>), takeDirectory )-import System.Directory-         ( createDirectoryIfMissing )--storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()-storeAnonymous reports = sequence_-  [ appendFile file (concatMap format reports')-  | (repo, reports') <- separate reports-  , let file = repoLocalDir repo </> "build-reports.log" ]-  --TODO: make this concurrency safe, either lock the report file or make sure-  -- the writes for each report are atomic (under 4k and flush at boundaries)--  where-    format r = '\n' : showBuildReport r ++ "\n"-    separate :: [(BuildReport, Maybe Repo)]-             -> [(Repo, [BuildReport])]-    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))-             . map (concatMap toList)-             . L.groupBy (equating (repoName' . head))-             . sortBy (comparing (repoName' . head))-             . groupBy (equating repoName')-             . onlyRemote--    repoName' (_,_,rrepo) = remoteRepoName rrepo--    onlyRemote :: [(BuildReport, Maybe Repo)]-               -> [(BuildReport, Repo, RemoteRepo)]-    onlyRemote rs =-      [ (report, repo, remoteRepo)-      | (report, Just repo) <- rs-      , Just remoteRepo     <- [maybeRepoRemote repo]-      ]--storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]-           -> Platform -> IO ()-storeLocal cinfo templates reports platform = sequence_-  [ do createDirectoryIfMissing True (takeDirectory file)-       appendFile file output-       --TODO: make this concurrency safe, either lock the report file or make-       --      sure the writes for each report are atomic-  | (file, reports') <- groupByFileName-                          [ (reportFileName template report, report)-                          | template <- templates-                          , (report, _repo) <- reports ]-  , let output = concatMap format reports'-  ]-  where-    format r = '\n' : showBuildReport r ++ "\n"--    reportFileName template report =-        fromPathTemplate (substPathTemplate env template)-      where env = initialPathTemplateEnv-                    (BuildReport.package  report)-                    -- TODO: In principle, we can support $pkgkey, but only-                    -- if the configure step succeeds.  So add a Maybe field-                    -- to the build report, and either use that or make up-                    -- a fake identifier if it's not available.-                    (error "storeLocal: package key not available")-                    cinfo-                    platform--    groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))-                    . L.groupBy (equating  fst)-                    . sortBy  (comparing fst)---- --------------------------------------------------------------- * InstallPlan support--- --------------------------------------------------------------fromInstallPlan :: Platform -> CompilerId-                -> InstallPlan-                -> BuildOutcomes-                -> [(BuildReport, Maybe Repo)]-fromInstallPlan platform comp plan buildOutcomes =-     mapMaybe (\pkg -> fromPlanPackage-                         platform comp pkg-                         (InstallPlan.lookupBuildOutcome pkg buildOutcomes))-   . InstallPlan.toList-   $ plan--fromPlanPackage :: Platform -> CompilerId-                -> InstallPlan.PlanPackage-                -> Maybe BuildOutcome-                -> Maybe (BuildReport, Maybe Repo)-fromPlanPackage (Platform arch os) comp-                (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))-                (Just buildResult) =-      Just ( newBuildReport os arch comp-                             (packageId srcPkg) flags-                             (map packageId (CD.nonSetupDeps deps))-                             buildResult-           , extractRepo srcPkg)-  where-    extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ })-                  = Just repo-    extractRepo _ = Nothing--fromPlanPackage _ _ _ _ = Nothing---fromPlanningFailure :: Platform -> CompilerId-    -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]-fromPlanningFailure (Platform arch os) comp pkgids flags =-  [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing)-  | pkgid <- pkgids ]
− Distribution/Client/BuildReports/Types.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.BuildReports.Types--- Copyright   :  (c) Duncan Coutts 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Types related to build reporting----------------------------------------------------------------------------------module Distribution.Client.BuildReports.Types (-    ReportLevel(..),-    BuildReport (..),-    InstallOutcome(..),-    Outcome(..),-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp--import Distribution.Compiler           (CompilerId (..))-import Distribution.PackageDescription (FlagAssignment)-import Distribution.System             (Arch, OS)-import Distribution.Types.PackageId    (PackageIdentifier)------------------------------------------------------------------------------------ ReportLevel----------------------------------------------------------------------------------data ReportLevel = NoReports | AnonymousReports | DetailedReports-  deriving (Eq, Ord, Enum, Bounded, Show, Generic)--instance Binary ReportLevel-instance Structured ReportLevel--instance Pretty ReportLevel where-  pretty NoReports        = Disp.text "none"-  pretty AnonymousReports = Disp.text "anonymous"-  pretty DetailedReports  = Disp.text "detailed"--instance Parsec ReportLevel where-  parsec = do-    name <- P.munch1 isAlpha-    case lowercase name of-      "none"       -> return NoReports-      "anonymous"  -> return AnonymousReports-      "detailed"   -> return DetailedReports-      _            -> P.unexpected $ "ReportLevel: " ++ name--lowercase :: String -> String-lowercase = map toLower------------------------------------------------------------------------------------ BuildReport----------------------------------------------------------------------------------data BuildReport = BuildReport {-    -- | The package this build report is about-    package         :: PackageIdentifier,--    -- | The OS and Arch the package was built on-    os              :: OS,-    arch            :: Arch,--    -- | The Haskell compiler (and hopefully version) used-    compiler        :: CompilerId,--    -- | The uploading client, ie cabal-install-x.y.z-    client          :: PackageIdentifier,--    -- | Which configurations flags we used-    flagAssignment  :: FlagAssignment,--    -- | Which dependent packages we were using exactly-    dependencies    :: [PackageIdentifier],--    -- | Did installing work ok?-    installOutcome  :: InstallOutcome,--    --   Which version of the Cabal library was used to compile the Setup.hs---    cabalVersion    :: Version,--    --   Which build tools we were using (with versions)---    tools      :: [PackageIdentifier],--    -- | Configure outcome, did configure work ok?-    docsOutcome     :: Outcome,--    -- | Configure outcome, did configure work ok?-    testsOutcome    :: Outcome-  }-  deriving (Eq, Show, Generic)-------------------------------------------------------------------------------------- InstallOutcome----------------------------------------------------------------------------------data InstallOutcome-   = PlanningFailed-   | DependencyFailed PackageIdentifier-   | DownloadFailed-   | UnpackFailed-   | SetupFailed-   | ConfigureFailed-   | BuildFailed-   | TestsFailed-   | InstallFailed-   | InstallOk-  deriving (Eq, Show, Generic)--instance Pretty InstallOutcome where-  pretty PlanningFailed  = Disp.text "PlanningFailed"-  pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid-  pretty DownloadFailed  = Disp.text "DownloadFailed"-  pretty UnpackFailed    = Disp.text "UnpackFailed"-  pretty SetupFailed     = Disp.text "SetupFailed"-  pretty ConfigureFailed = Disp.text "ConfigureFailed"-  pretty BuildFailed     = Disp.text "BuildFailed"-  pretty TestsFailed     = Disp.text "TestsFailed"-  pretty InstallFailed   = Disp.text "InstallFailed"-  pretty InstallOk       = Disp.text "InstallOk"--instance Parsec InstallOutcome where-  parsec = do-    name <- P.munch1 isAlpha-    case name of-      "PlanningFailed"   -> return PlanningFailed-      "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec-      "DownloadFailed"   -> return DownloadFailed-      "UnpackFailed"     -> return UnpackFailed-      "SetupFailed"      -> return SetupFailed-      "ConfigureFailed"  -> return ConfigureFailed-      "BuildFailed"      -> return BuildFailed-      "TestsFailed"      -> return TestsFailed-      "InstallFailed"    -> return InstallFailed-      "InstallOk"        -> return InstallOk-      _                  -> P.unexpected $ "InstallOutcome: " ++ name------------------------------------------------------------------------------------ Outcome----------------------------------------------------------------------------------data Outcome = NotTried | Failed | Ok-  deriving (Eq, Show, Enum, Bounded, Generic)--instance Pretty Outcome where-  pretty NotTried = Disp.text "NotTried"-  pretty Failed   = Disp.text "Failed"-  pretty Ok       = Disp.text "Ok"--instance Parsec Outcome where-  parsec = do-    name <- P.munch1 isAlpha-    case name of-      "NotTried" -> return NotTried-      "Failed"   -> return Failed-      "Ok"       -> return Ok-      _          -> P.unexpected $ "Outcome: " ++ name
− Distribution/Client/BuildReports/Upload.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE CPP, PatternGuards #-}--- This is a quick hack for uploading build reports to Hackage.--module Distribution.Client.BuildReports.Upload-    ( BuildLog-    , BuildReportId-    , uploadReports-    ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--{--import Network.Browser-         ( BrowserAction, request, setAllowRedirects )-import Network.HTTP-         ( Header(..), HeaderName(..)-         , Request(..), RequestMethod(..), Response(..) )-import Network.TCP (HandleStream)--}-import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)--import System.FilePath.Posix-         ( (</>) )-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport)-import Distribution.Simple.Utils (die')-import Distribution.Client.HttpUtils-import Distribution.Client.Setup-         ( RepoContext(..) )--type BuildReportId = URI-type BuildLog = String--uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()-uploadReports verbosity repoCtxt auth uri reports = do-  for_ reports $ \(report, mbBuildLog) -> do-     buildId <- postBuildReport verbosity repoCtxt auth uri report-     case mbBuildLog of-       Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog-       Nothing       -> return ()--postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId-postBuildReport verbosity repoCtxt auth uri buildReport = do-  let fullURI = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" }-  transport <- repoContextGetTransport repoCtxt-  res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth)-  case res of-    (303, redir) -> return $ undefined redir --TODO parse redir-    _ -> die' verbosity "unrecognized response" -- give response--{--  setAllowRedirects False-  (_, response) <- request Request {-    rqURI     = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" },-    rqMethod  = POST,-    rqHeaders = [Header HdrContentType   ("text/plain"),-                 Header HdrContentLength (show (length body)),-                 Header HdrAccept        ("text/plain")],-    rqBody    = body-  }-  case rspCode response of-    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location-#if defined(VERSION_network_uri)-                                     return $ relativeTo rel uri-#elif defined(VERSION_network)-#if MIN_VERSION_network(2,4,0)-                                     return $ relativeTo rel uri-#else-                                     relativeTo rel uri-#endif-#endif-                                  | Header HdrLocation location <- rspHeaders response ]-              -> return $ buildId-    _         -> error "Unrecognised response from server."-  where body  = BuildReport.show buildReport--}----- TODO force this to be a PUT?--putBuildLog :: Verbosity -> RepoContext -> (String, String)-            -> BuildReportId -> BuildLog-            -> IO ()-putBuildLog verbosity repoCtxt auth reportId buildLog = do-  let fullURI = reportId {uriPath = uriPath reportId </> "log"}-  transport <- repoContextGetTransport repoCtxt-  res <- postHttp transport verbosity fullURI buildLog (Just auth)-  case res of-    (200, _) -> return ()-    _ -> die' verbosity "unrecognized response" -- give response
− Distribution/Client/Check.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Check--- Copyright   :  (c) Lennart Kolmodin 2008--- License     :  BSD-like------ Maintainer  :  kolmodin@haskell.org--- Stability   :  provisional--- Portability :  portable------ Check a package for common mistakes----------------------------------------------------------------------------------module Distribution.Client.Check (-    check-  ) where---import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.Utils.Parsec              (renderParseError)-import Distribution.PackageDescription               (GenericPackageDescription)-import Distribution.PackageDescription.Check-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.PackageDescription.Parsec-       (parseGenericPackageDescription, runParseResult)-import Distribution.Parsec                           (PWarning (..), showPError, showPWarning)-import Distribution.Simple.Utils                     (defaultPackageDesc, die', notice, warn)-import System.IO                                     (hPutStr, stderr)--import qualified Data.ByteString  as BS-import qualified System.Directory as Dir--readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)-readGenericPackageDescriptionCheck verbosity fpath = do-    exists <- Dir.doesFileExist fpath-    unless exists $-      die' verbosity $-        "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."-    bs <- BS.readFile fpath-    let (warnings, result) = runParseResult (parseGenericPackageDescription bs)-    case result of-        Left (_, errors) -> do-            traverse_ (warn verbosity . showPError fpath) errors-            hPutStr stderr $ renderParseError fpath bs errors warnings-            die' verbosity "parse error"-        Right x  -> return (warnings, x)---- | Note: must be called with the CWD set to the directory containing--- the '.cabal' file.-check :: Verbosity -> IO Bool-check verbosity = do-    pdfile <- defaultPackageDesc verbosity-    (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile-    -- convert parse warnings into PackageChecks-    -- Note: we /could/ pick different levels, based on warning type.-    let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ]-    -- flatten the generic package description into a regular package-    -- description-    -- TODO: this may give more warnings than it should give;-    --       consider two branches of a condition, one saying-    --          ghc-options: -Wall-    --       and the other-    --          ghc-options: -Werror-    --      joined into-    --          ghc-options: -Wall -Werror-    --      checkPackages will yield a warning on the last line, but it-    --      would not on each individual branch.-    --      Hovever, this is the same way hackage does it, so we will yield-    --      the exact same errors as it will.-    let pkg_desc = flattenPackageDescription ppd-    ioChecks <- checkPackageFiles verbosity pkg_desc "."-    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws'-        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]-        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]-        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]-                          ++ [ x | x@PackageDistSuspiciousWarn {}  <- packageChecks ]-        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]--    unless (null buildImpossible) $ do-        warn verbosity "The package will not build sanely due to these errors:"-        printCheckMessages buildImpossible--    unless (null buildWarning) $ do-        warn verbosity "The following warnings are likely to affect your build negatively:"-        printCheckMessages buildWarning--    unless (null distSuspicious) $ do-        warn verbosity "These warnings may cause trouble when distributing the package:"-        printCheckMessages distSuspicious--    unless (null distInexusable) $ do-        warn verbosity "The following errors will cause portability problems on other environments:"-        printCheckMessages distInexusable--    let isDistError (PackageDistSuspicious     {}) = False-        isDistError (PackageDistSuspiciousWarn {}) = False-        isDistError _                              = True-        isCheckError (PackageDistSuspiciousWarn {}) = False-        isCheckError _                              = True-        errors = filter isDistError packageChecks--    unless (null errors) $-        warn verbosity "Hackage would reject this package."--    when (null packageChecks) $-        notice verbosity "No errors or warnings could be found in the package."--    return (not . any isCheckError $ packageChecks)--  where-    printCheckMessages = traverse_ (warn verbosity . explanation)
− Distribution/Client/CmdBench.hs 
@@ -1,252 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | cabal-install CLI command: bench----module Distribution.Client.CmdBench (-    -- * The @bench@ CLI and action-    benchCommand,-    benchAction,--    -- * Internals exposed for testing-    componentNotBenchmarkProblem,-    isSubComponentProblem,-    noBenchmarksProblem,-    selectPackageTargets,-    selectComponentTarget-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.ProjectOrchestration-import Distribution.Client.CmdErrorMessages-         ( renderTargetSelector, showTargetSelector, renderTargetProblem,-           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,-           targetSelectorFilter )-import Distribution.Client.TargetProblem-         ( TargetProblem (..) )-import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..) )-import Distribution.Simple.Flag-         ( fromFlagOrDefault )-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )-import Distribution.Verbosity-         ( normal )-import Distribution.Simple.Utils-         ( wrapText, die' )--benchCommand :: CommandUI (NixStyleFlags ())-benchCommand = CommandUI {-  commandName         = "v2-bench",-  commandSynopsis     = "Run benchmarks",-  commandUsage        = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ],-  commandDescription  = Just $ \_ -> wrapText $-        "Runs the specified benchmarks, first ensuring they are up to "-     ++ "date.\n\n"--     ++ "Any benchmark in any package in the project can be specified. "-     ++ "A package can be specified in which case all the benchmarks in the "-     ++ "package are run. The default is to run all the benchmarks in the "-     ++ "package in the current directory.\n\n"--     ++ "Dependencies are built or rebuilt as necessary. Additional "-     ++ "configuration flags can be specified on the command line and these "-     ++ "extend the project configuration from the 'cabal.project', "-     ++ "'cabal.project.local' and other files.",-  commandNotes        = Just $ \pname ->-        "Examples:\n"-     ++ "  " ++ pname ++ " v2-bench\n"-     ++ "    Run all the benchmarks in the package in the current directory\n"-     ++ "  " ++ pname ++ " v2-bench pkgname\n"-     ++ "    Run all the benchmarks in the package named pkgname\n"-     ++ "  " ++ pname ++ " v2-bench cname\n"-     ++ "    Run the benchmark named cname\n"-     ++ "  " ++ pname ++ " v2-bench cname -O2\n"-     ++ "    Run the benchmark built with '-O2' (including local libs used)\n"--   , commandDefaultFlags = defaultNixStyleFlags ()-   , commandOptions      = nixStyleOptions (const [])-   }----- | The @build@ command does a lot. It brings the install plan up to date,--- selects that part of the plan needed by the given or implicit targets and--- then executes the plan.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do--    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--    targetSelectors <- either (reportTargetSelectorProblems verbosity) return-                   =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do--            when (buildSettingOnlyDeps (buildSettings baseCtx)) $-              die' verbosity $-                  "The bench command does not support '--only-dependencies'. "-               ++ "You may wish to use 'build --only-dependencies' and then "-               ++ "use 'bench'."--            -- Interpret the targets on the command line as bench targets-            -- (as opposed to say build or haddock targets).-            targets <- either (reportTargetProblems verbosity) return-                     $ resolveTargets-                         selectPackageTargets-                         selectComponentTarget-                         elaboratedPlan-                         Nothing-                         targetSelectors--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionBench-                                    targets-                                    elaboratedPlan-            return (elaboratedPlan', targets)--    printPlan verbosity baseCtx buildCtx--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx-    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags -                  mempty -- ClientInstallFlags, not needed here---- | This defines what a 'TargetSelector' means for the @bench@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @bench@ command we select all buildable benchmarks,--- or fail if there are no benchmarks or no buildable benchmarks.----selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either BenchTargetProblem [k]-selectPackageTargets targetSelector targets--    -- If there are any buildable benchmark targets then we select those-  | not (null targetsBenchBuildable)-  = Right targetsBenchBuildable--    -- If there are benchmarks but none are buildable then we report those-  | not (null targetsBench)-  = Left (TargetProblemNoneEnabled targetSelector targetsBench)--    -- If there are no benchmarks but some other targets then we report that-  | not (null targets)-  = Left (noBenchmarksProblem targetSelector)--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    targetsBenchBuildable = selectBuildableTargets-                          . filterTargetsKind BenchKind-                          $ targets--    targetsBench          = forgetTargetsDetail-                          . filterTargetsKind BenchKind-                          $ targets----- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @bench@ command we just need to check it is a benchmark, in addition--- to the basic checks on being buildable etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either BenchTargetProblem k-selectComponentTarget subtarget@WholeComponent t-  | CBenchName _ <- availableTargetComponentName t-  = selectComponentTargetBasic subtarget t-  | otherwise-  = Left (componentNotBenchmarkProblem-           (availableTargetPackageId t)-           (availableTargetComponentName t))--selectComponentTarget subtarget t-  = Left (isSubComponentProblem-           (availableTargetPackageId t)-           (availableTargetComponentName t)-           subtarget)---- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.----data BenchProblem =-     -- | The 'TargetSelector' matches targets but no benchmarks-     TargetProblemNoBenchmarks TargetSelector--     -- | The 'TargetSelector' refers to a component that is not a benchmark-   | TargetProblemComponentNotBenchmark PackageId ComponentName--     -- | Asking to benchmark an individual file or module is not supported-   | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget-  deriving (Eq, Show)---type BenchTargetProblem = TargetProblem BenchProblem--noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem-noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks--componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem-componentNotBenchmarkProblem pkgid name = CustomTargetProblem $-  TargetProblemComponentNotBenchmark pkgid name--isSubComponentProblem-  :: PackageId-  -> ComponentName-  -> SubComponentTarget-  -> TargetProblem BenchProblem-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $-    TargetProblemIsSubComponent pkgid name subcomponent--reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderBenchTargetProblem--renderBenchTargetProblem :: BenchTargetProblem -> String-renderBenchTargetProblem (TargetProblemNoTargets targetSelector) =-    case targetSelectorFilter targetSelector of-      Just kind | kind /= BenchKind-        -> "The bench command is for running benchmarks, but the target '"-           ++ showTargetSelector targetSelector ++ "' refers to "-           ++ renderTargetSelector targetSelector ++ "."--      _ -> renderTargetProblemNoTargets "benchmark" targetSelector-renderBenchTargetProblem problem =-    renderTargetProblem "benchmark" renderBenchProblem problem--renderBenchProblem :: BenchProblem -> String-renderBenchProblem (TargetProblemNoBenchmarks targetSelector) =-    "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any benchmarks."--renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) =-    "The bench command is for running benchmarks, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " from the package "- ++ prettyShow pkgid ++ "."-  where-    targetSelector = TargetComponent pkgid cname WholeComponent--renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) =-    "The bench command can only run benchmarks as a whole, "- ++ "not files or modules within them, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ "."-  where-    targetSelector = TargetComponent pkgid cname subtarget
− Distribution/Client/CmdBuild.hs 
@@ -1,196 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--- | cabal-install CLI command: build----module Distribution.Client.CmdBuild (-    -- * The @build@ CLI and action-    buildCommand,-    buildAction,--    -- * Internals exposed for testing-    selectPackageTargets,-    selectComponentTarget-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.ProjectOrchestration-import Distribution.Client.TargetProblem-         ( TargetProblem (..), TargetProblem' )-import Distribution.Client.CmdErrorMessages--import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..), yesNoOpt )-import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault )-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives, option, optionName )-import Distribution.Verbosity-         ( normal )-import Distribution.Simple.Utils-         ( wrapText, die' )--import qualified Data.Map as Map---buildCommand :: CommandUI (NixStyleFlags BuildFlags)-buildCommand = CommandUI {-  commandName         = "v2-build",-  commandSynopsis     = "Compile targets within the project.",-  commandUsage        = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ],-  commandDescription  = Just $ \_ -> wrapText $-        "Build one or more targets from within the project. The available "-     ++ "targets are the packages in the project as well as individual "-     ++ "components within those packages, including libraries, executables, "-     ++ "test-suites or benchmarks. Targets can be specified by name or "-     ++ "location. If no target is specified then the default is to build "-     ++ "the package in the current directory.\n\n"--     ++ "Dependencies are built or rebuilt as necessary. Additional "-     ++ "configuration flags can be specified on the command line and these "-     ++ "extend the project configuration from the 'cabal.project', "-     ++ "'cabal.project.local' and other files.",-  commandNotes        = Just $ \pname ->-        "Examples:\n"-     ++ "  " ++ pname ++ " v2-build\n"-     ++ "    Build the package in the current directory "-     ++ "or all packages in the project\n"-     ++ "  " ++ pname ++ " v2-build pkgname\n"-     ++ "    Build the package named pkgname in the project\n"-     ++ "  " ++ pname ++ " v2-build ./pkgfoo\n"-     ++ "    Build the package in the ./pkgfoo directory\n"-     ++ "  " ++ pname ++ " v2-build cname\n"-     ++ "    Build the component named cname in the project\n"-     ++ "  " ++ pname ++ " v2-build cname --enable-profiling\n"-     ++ "    Build the component in profiling mode "-     ++ "(including dependencies as needed)\n"--  , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")-                        . nixStyleOptions (\showOrParseArgs ->-    [ option [] ["only-configure"]-        "Instead of performing a full build just run the configure step"-        buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v })-        (yesNoOpt showOrParseArgs)-    ])-  }--data BuildFlags = BuildFlags-    { buildOnlyConfigure  :: Flag Bool-    }--defaultBuildFlags :: BuildFlags-defaultBuildFlags = BuildFlags-    { buildOnlyConfigure = toFlag False-    }---- | The @build@ command does a lot. It brings the install plan up to date,--- selects that part of the plan needed by the given or implicit targets and--- then executes the plan.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()-buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do-    -- TODO: This flags defaults business is ugly-    let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags-                                 <> buildOnlyConfigure buildFlags)-        targetAction-            | onlyConfigure = TargetActionConfigure-            | otherwise = TargetActionBuild--    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--    targetSelectors <--      either (reportTargetSelectorProblems verbosity) return-      =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do--            -- Interpret the targets on the command line as build targets-            -- (as opposed to say repl or haddock targets).-            targets <- either (reportBuildTargetProblems verbosity) return-                     $ resolveTargets-                         selectPackageTargets-                         selectComponentTarget-                         elaboratedPlan-                         Nothing-                         targetSelectors--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    targetAction-                                    targets-                                    elaboratedPlan-            elaboratedPlan'' <--              if buildSettingOnlyDeps (buildSettings baseCtx)-                then either (reportCannotPruneDependencies verbosity) return $-                     pruneInstallPlanToDependencies (Map.keysSet targets)-                                                    elaboratedPlan'-                else return elaboratedPlan'--            return (elaboratedPlan'', targets)--    printPlan verbosity baseCtx buildCtx--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx-    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags-                  mempty -- ClientInstallFlags, not needed here---- | This defines what a 'TargetSelector' means for the @bench@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @build@ command select all components except non-buildable--- and disabled tests\/benchmarks, fail if there are no such--- components----selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either TargetProblem' [k]-selectPackageTargets targetSelector targets--    -- If there are any buildable targets then we select those-  | not (null targetsBuildable)-  = Right targetsBuildable--    -- If there are targets but none are buildable then we report those-  | not (null targets)-  = Left (TargetProblemNoneEnabled targetSelector targets')--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    targets'         = forgetTargetsDetail targets-    targetsBuildable = selectBuildableTargetsWith-                         (buildable targetSelector)-                         targets--    -- When there's a target filter like "pkg:tests" then we do select tests,-    -- but if it's just a target like "pkg" then we don't build tests unless-    -- they are requested by default (i.e. by using --enable-tests)-    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False-    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False-    buildable _ _ = True---- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @build@ command we just need the basic checks on being buildable etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem' k-selectComponentTarget = selectComponentTargetBasic--reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a-reportBuildTargetProblems verbosity problems =-  reportTargetProblems verbosity "build" problems--reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a-reportCannotPruneDependencies verbosity =-    die' verbosity . renderCannotPruneDependencies
− Distribution/Client/CmdClean.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Distribution.Client.CmdClean (cleanCommand, cleanAction) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.DistDirLayout-    ( DistDirLayout(..), defaultDistDirLayout )-import Distribution.Client.ProjectConfig-    ( findProjectRoot )-import Distribution.Client.Setup-    ( GlobalFlags )-import Distribution.ReadE ( succeedReadE )-import Distribution.Simple.Setup-    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe-    , optionDistPref, optionVerbosity, falseArg-    )-import Distribution.Simple.Command-    ( CommandUI(..), option, reqArg )-import Distribution.Simple.Utils-    ( info, die', wrapText, handleDoesNotExist )-import Distribution.Verbosity-    ( normal )--import System.Directory-    ( removeDirectoryRecursive, removeFile-    , doesDirectoryExist, getDirectoryContents )-import System.FilePath-    ( (</>) )--data CleanFlags = CleanFlags-    { cleanSaveConfig  :: Flag Bool-    , cleanVerbosity   :: Flag Verbosity-    , cleanDistDir     :: Flag FilePath-    , cleanProjectFile :: Flag FilePath-    } deriving (Eq)--defaultCleanFlags :: CleanFlags-defaultCleanFlags = CleanFlags-    { cleanSaveConfig  = toFlag False-    , cleanVerbosity   = toFlag normal-    , cleanDistDir     = NoFlag-    , cleanProjectFile = mempty-    }--cleanCommand :: CommandUI CleanFlags-cleanCommand = CommandUI-    { commandName         = "v2-clean"-    , commandSynopsis     = "Clean the package store and remove temporary files."-    , commandUsage        = \pname ->-        "Usage: " ++ pname ++ " new-clean [FLAGS]\n"-    , commandDescription  = Just $ \_ -> wrapText $-        "Removes all temporary files created during the building process "-     ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "-     ++ "local caches (by default).\n\n"-    , commandNotes        = Nothing-    , commandDefaultFlags = defaultCleanFlags-    , commandOptions      = \showOrParseArgs ->-        [ optionVerbosity-            cleanVerbosity (\v flags -> flags { cleanVerbosity = v })-        , optionDistPref-            cleanDistDir (\dd flags -> flags { cleanDistDir = dd })-            showOrParseArgs-        , option [] ["project-file"]-            ("Set the name of the cabal.project file"-             ++ " to search for in parent directories")-            cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf})-            (reqArg "FILE" (succeedReadE Flag) flagToList)-        , option ['s'] ["save-config"]-            "Save configuration, only remove build artifacts"-            cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc })-            falseArg-        ]-  }--cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()-cleanAction CleanFlags{..} extraArgs _ = do-    let verbosity      = fromFlagOrDefault normal cleanVerbosity-        saveConfig     = fromFlagOrDefault False  cleanSaveConfig-        mdistDirectory = flagToMaybe cleanDistDir-        mprojectFile   = flagToMaybe cleanProjectFile--    unless (null extraArgs) $-        die' verbosity $ "'clean' doesn't take any extra arguments: "-                         ++ unwords extraArgs--    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile--    let distLayout = defaultDistDirLayout projectRoot mdistDirectory--    if saveConfig-        then do-            let buildRoot = distBuildRootDirectory distLayout--            buildRootExists <- doesDirectoryExist buildRoot--            when buildRootExists $ do-                info verbosity ("Deleting build root (" ++ buildRoot ++ ")")-                handleDoesNotExist () $ removeDirectoryRecursive buildRoot-        else do-            let distRoot = distDirectory distLayout--            info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")-            handleDoesNotExist () $ removeDirectoryRecursive distRoot--    removeEnvFiles (distProjectRootDirectory distLayout)--removeEnvFiles :: FilePath -> IO ()-removeEnvFiles dir =-  (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))-  =<< getDirectoryContents dir
− Distribution/Client/CmdConfigure.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--- | cabal-install CLI command: configure----module Distribution.Client.CmdConfigure (-    configureCommand,-    configureAction,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import System.Directory-import System.FilePath-import qualified Data.Map as Map--import Distribution.Client.ProjectOrchestration-import Distribution.Client.ProjectConfig-         ( writeProjectLocalExtraConfig )--import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..) )-import Distribution.Simple.Flag-         ( fromFlagOrDefault )-import Distribution.Verbosity-         ( normal )--import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives, optionName )-import Distribution.Simple.Utils-         ( wrapText, notice )--import Distribution.Client.DistDirLayout-         ( DistDirLayout(..) )--configureCommand :: CommandUI (NixStyleFlags ())-configureCommand = CommandUI {-  commandName         = "v2-configure",-  commandSynopsis     = "Add extra project configuration",-  commandUsage        = usageAlternatives "v2-configure" [ "[FLAGS]" ],-  commandDescription  = Just $ \_ -> wrapText $-        "Adjust how the project is built by setting additional package flags "-     ++ "and other flags.\n\n"--     ++ "The configuration options are written to the 'cabal.project.local' "-     ++ "file (or '$project_file.local', if '--project-file' is specified) "-     ++ "which extends the configuration from the 'cabal.project' file "-     ++ "(if any). This combination is used as the project configuration for "-     ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it "-     ++ "can be extended/overridden on a per-command basis.\n\n"--     ++ "The v2-configure command also checks that the project configuration "-     ++ "will work. In particular it checks that there is a consistent set of "-     ++ "dependencies for the project as a whole.\n\n"--     ++ "The 'cabal.project.local' file persists across 'v2-clean' but is "-     ++ "overwritten on the next use of the 'v2-configure' command. The "-     ++ "intention is that the 'cabal.project' file should be kept in source "-     ++ "control but the 'cabal.project.local' should not.\n\n"--     ++ "It is never necessary to use the 'v2-configure' command. It is "-     ++ "merely a convenience in cases where you do not want to specify flags "-     ++ "to 'v2-build' (and other commands) every time and yet do not want "-     ++ "to alter the 'cabal.project' persistently.",-  commandNotes        = Just $ \pname ->-        "Examples:\n"-     ++ "  " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n"-     ++ "    Adjust the project configuration to use the given compiler\n"-     ++ "    program and check the resulting configuration works.\n"-     ++ "  " ++ pname ++ " v2-configure\n"-     ++ "    Reset the local configuration to empty and check the overall\n"-     ++ "    project configuration works.\n"--  , commandDefaultFlags = defaultNixStyleFlags ()-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")-                        . nixStyleOptions (const [])-  }---- | To a first approximation, the @configure@ just runs the first phase of--- the @build@ command where we bring the install plan up to date (thus--- checking that it's possible).------ The only difference is that @configure@ also allows the user to specify--- some extra config flags which we save in the file @cabal.project.local@.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do-    --TODO: deal with _extraArgs, since flags with wrong syntax end up there--    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--    -- Write out the @cabal.project.local@ so it gets picked up by the-    -- planning phase. If old config exists, then print the contents-    -- before overwriting--    let localFile = distProjectFile (distDirLayout baseCtx) "local"-        -- | Chooses cabal.project.local~, or if it already exists-        -- cabal.project.local~0, cabal.project.local~1 etc.-        firstFreeBackup = firstFreeBackup' (0 :: Int)-        firstFreeBackup' i = do-          let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1))-          exists <- doesFileExist backup-          if exists-            then firstFreeBackup' (i + 1)-            else return backup--    -- If cabal.project.local already exists, back up to cabal.project.local~[n]-    exists <- doesFileExist localFile-    when exists $ do-        backup <- firstFreeBackup-        notice verbosity $-          quote (takeFileName localFile) <> " already exists, backing it up to "-          <> quote (takeFileName backup) <> "."-        copyFile localFile backup-    writeProjectLocalExtraConfig (distDirLayout baseCtx)-                                 cliConfig--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan ->--            -- TODO: Select the same subset of targets as 'CmdBuild' would-            -- pick (ignoring, for example, executables in libraries-            -- we depend on). But we don't want it to fail, so actually we-            -- have to do it slightly differently from build.-            return (elaboratedPlan, Map.empty)--    let baseCtx' = baseCtx {-                      buildSettings = (buildSettings baseCtx) {-                        buildSettingDryRun = True-                      }-                    }--    -- TODO: Hmm, but we don't have any targets. Currently this prints-    -- what we would build if we were to build everything. Could pick-    -- implicit target like "."-    ---    -- TODO: should we say what's in the project (+deps) as a whole?-    printPlan verbosity baseCtx' buildCtx-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags-                  mempty -- ClientInstallFlags, not needed here-    quote s = "'" <> s <> "'"-
− Distribution/Client/CmdErrorMessages.hs 
@@ -1,441 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}----- | Utilities to help format error messages for the various CLI commands.----module Distribution.Client.CmdErrorMessages (-    module Distribution.Client.CmdErrorMessages,-    module Distribution.Client.TargetSelector,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.ProjectPlanning-         ( AvailableTarget(..), AvailableTargetStatus(..),-           CannotPruneDependencies(..), TargetRequested(..) )-import Distribution.Client.TargetSelector-         ( SubComponentTarget(..) )-import Distribution.Client.TargetProblem-         ( TargetProblem(..), TargetProblem' )-import Distribution.Client.TargetSelector-         ( ComponentKind(..), ComponentKindFilter, TargetSelector(..),-           componentKind, showTargetSelector )--import Distribution.Package-         ( PackageId, packageId, PackageName, packageName )-import Distribution.Simple.Utils-         ( die' )-import Distribution.Types.ComponentName-         ( ComponentName(..), showComponentName )-import Distribution.Types.LibraryName-         ( LibraryName(..) )-import Distribution.Solver.Types.OptionalStanza-         ( OptionalStanza(..) )--import qualified Data.List.NonEmpty as NE----------------------------- Singular or plural------- | A tag used in rendering messages to distinguish singular or plural.----data Plural = Singular | Plural---- | Used to render a singular or plural version of something------ > plural (listPlural theThings) "it is" "they are"----plural :: Plural -> a -> a -> a-plural Singular si _pl = si-plural Plural  _si  pl = pl---- | Singular for singleton lists and plural otherwise.----listPlural :: [a] -> Plural-listPlural [_] = Singular-listPlural  _  = Plural-------------------------- Rendering lists------- | Render a list of things in the style @foo, bar and baz@-renderListCommaAnd :: [String] -> String-renderListCommaAnd []     = ""-renderListCommaAnd [x]    = x-renderListCommaAnd [x,x'] = x ++ " and " ++ x'-renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs---- | Render a list of things in the style @blah blah; this that; and the other@-renderListSemiAnd :: [String] -> String-renderListSemiAnd []     = ""-renderListSemiAnd [x]    = x-renderListSemiAnd [x,x'] = x ++ "; and " ++ x'-renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs---- | When rendering lists of things it often reads better to group related--- things, e.g. grouping components by package name------ > renderListSemiAnd--- >   [     "the package " ++ prettyShow pkgname ++ " components "--- >      ++ renderListCommaAnd showComponentName components--- >   | (pkgname, components) <- sortGroupOn packageName allcomponents ]----sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])]-sortGroupOn key = map (\(x:|xs) -> (key x, x:xs))-                . NE.groupBy ((==) `on` key)-                . sortBy  (compare `on` key)---------------------------------------------------------- Renderering for a few project and package types-----renderTargetSelector :: TargetSelector -> String-renderTargetSelector (TargetPackage _ pkgids Nothing) =-    "the " ++ plural (listPlural pkgids) "package" "packages" ++ " "- ++ renderListCommaAnd (map prettyShow pkgids)--renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) =-    "the " ++ renderComponentKind Plural kfilter- ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " "- ++ renderListCommaAnd (map prettyShow pkgids)--renderTargetSelector (TargetPackageNamed pkgname Nothing) =-    "the package " ++ prettyShow pkgname--renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) =-    "the " ++ renderComponentKind Plural kfilter- ++ " in the package " ++ prettyShow pkgname--renderTargetSelector (TargetAllPackages Nothing) =-    "all the packages in the project"--renderTargetSelector (TargetAllPackages (Just kfilter)) =-    "all the " ++ renderComponentKind Plural kfilter- ++ " in the project"--renderTargetSelector (TargetComponent pkgid cname subtarget) =-    renderSubComponentTarget subtarget ++ "the "- ++ renderComponentName (packageName pkgid) cname--renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) =-    renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname- ++ " in the package " ++ prettyShow pkgname--renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) =-    renderSubComponentTarget subtarget ++ "the "- ++ renderComponentName pkgname cname--renderSubComponentTarget :: SubComponentTarget -> String-renderSubComponentTarget WholeComponent         = ""-renderSubComponentTarget (FileTarget filename)  =-  "the file " ++ filename ++ "in "-renderSubComponentTarget (ModuleTarget modname) =-  "the module" ++ prettyShow modname ++ "in "---renderOptionalStanza :: Plural -> OptionalStanza -> String-renderOptionalStanza Singular TestStanzas  = "test suite"-renderOptionalStanza Plural   TestStanzas  = "test suites"-renderOptionalStanza Singular BenchStanzas = "benchmark"-renderOptionalStanza Plural   BenchStanzas = "benchmarks"---- | The optional stanza type (test suite or benchmark), if it is one.-optionalStanza :: ComponentName -> Maybe OptionalStanza-optionalStanza (CTestName  _) = Just TestStanzas-optionalStanza (CBenchName _) = Just BenchStanzas-optionalStanza _              = Nothing---- | Does the 'TargetSelector' potentially refer to one package or many?----targetSelectorPluralPkgs :: TargetSelector -> Plural-targetSelectorPluralPkgs (TargetAllPackages _)     = Plural-targetSelectorPluralPkgs (TargetPackage _ pids _)  = listPlural pids-targetSelectorPluralPkgs (TargetPackageNamed _ _)  = Singular-targetSelectorPluralPkgs  TargetComponent{}        = Singular-targetSelectorPluralPkgs  TargetComponentUnknown{} = Singular---- | Does the 'TargetSelector' refer to packages or to components?-targetSelectorRefersToPkgs :: TargetSelector -> Bool-targetSelectorRefersToPkgs (TargetAllPackages    mkfilter) = isNothing mkfilter-targetSelectorRefersToPkgs (TargetPackage    _ _ mkfilter) = isNothing mkfilter-targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter-targetSelectorRefersToPkgs  TargetComponent{}              = False-targetSelectorRefersToPkgs  TargetComponentUnknown{}       = False--targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter-targetSelectorFilter (TargetPackage    _ _ mkfilter) = mkfilter-targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter-targetSelectorFilter (TargetAllPackages    mkfilter) = mkfilter-targetSelectorFilter  TargetComponent{}              = Nothing-targetSelectorFilter  TargetComponentUnknown{}       = Nothing--renderComponentName :: PackageName -> ComponentName -> String-renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname-renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name-renderComponentName _ (CFLibName   name) = "foreign library " ++ prettyShow name-renderComponentName _ (CExeName    name) = "executable " ++ prettyShow name-renderComponentName _ (CTestName   name) = "test suite " ++ prettyShow name-renderComponentName _ (CBenchName  name) = "benchmark " ++ prettyShow name--renderComponentKind :: Plural -> ComponentKind -> String-renderComponentKind Singular ckind = case ckind of-  LibKind   -> "library"  -- internal/sub libs?-  FLibKind  -> "foreign library"-  ExeKind   -> "executable"-  TestKind  -> "test suite"-  BenchKind -> "benchmark"-renderComponentKind Plural ckind = case ckind of-  LibKind   -> "libraries"  -- internal/sub libs?-  FLibKind  -> "foreign libraries"-  ExeKind   -> "executables"-  TestKind  -> "test suites"-  BenchKind -> "benchmarks"------------------------------------------------------------- Renderering error messages for TargetProblem------- | Default implementation of 'reportTargetProblems' simply renders one problem per line.-reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a-reportTargetProblems verbosity verb =-  die' verbosity . unlines . map (renderTargetProblem verb absurd)---- | Default implementation of 'renderTargetProblem'.-renderTargetProblem-    :: String           -- ^ verb-    -> (a -> String)    -- ^ how to render custom problems-    -> TargetProblem a-    -> String-renderTargetProblem _verb f (CustomTargetProblem x) = f x-renderTargetProblem verb  _ (TargetProblemNoneEnabled targetSelector targets) =-    renderTargetProblemNoneEnabled verb targetSelector targets-renderTargetProblem verb  _ (TargetProblemNoTargets targetSelector) =-    renderTargetProblemNoTargets verb targetSelector--renderTargetProblem verb _ (TargetNotInProject pkgname) =-    "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "- ++ "in this project (either directly or indirectly). If you want to add it "- ++ "to the project then edit the cabal.project file."--renderTargetProblem verb _ (TargetAvailableInIndex pkgname) =-    "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "- ++ "in this project (either directly or indirectly), but it is in the current "- ++ "package index. If you want to add it to the project then edit the "- ++ "cabal.project file."--renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) =-    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "- ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal "- ++ "does not currently support building test suites or benchmarks of "- ++ "non-local dependencies. To run test suites or benchmarks from "- ++ "dependencies you can unpack the package locally and adjust the "- ++ "cabal.project file to include that package directory."--renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) =-    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is "- ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid)- ++ ".cabal' file (at least for the current configuration). If you believe it "- ++ "should be buildable then check the .cabal file to see if the buildable "- ++ "property is conditional on flags. Alternatively you may simply have to "- ++ "edit the .cabal file to declare it as buildable and fix any resulting "- ++ "build problems."--renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) =-    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because "- ++ "building " ++ compkinds ++ " has been explicitly disabled in the "- ++ "configuration. You can adjust this configuration in the "- ++ "cabal.project{.local} file either for all packages in the project or on "- ++ "a per-package basis. Note that if you do not explicitly disable "- ++ compkinds ++ " then the solver will merely try to make a plan with "- ++ "them available, so you may wish to explicitly enable them which will "- ++ "require the solver to find a plan with them available or to fail with an "- ++ "explanation."-   where-     compkinds = renderComponentKind Plural (componentKind cname)--renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) =-    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "- ++ "solver did not find a plan that included the " ++ compkinds- ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with "- ++ compkinds ++ " explicitly enabled in the configuration in the "- ++ "cabal.project{.local} file. This will ask the solver to find a plan with "- ++ "the " ++ compkinds ++ " available. It will either fail with an "- ++ "explanation or find a different plan that uses different versions of some "- ++ "other packages. Use the '--dry-run' flag to see package versions and "- ++ "check that you are happy with the choices."-   where-     compkinds = renderComponentKind Plural (componentKind cname)--renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) =-    "Cannot " ++ verb ++ " the "- ++ (case ecname of-      Left ucname -> "component " ++ prettyShow ucname-      Right cname -> renderComponentName pkgname cname)- ++ " from the package " ++ prettyShow pkgname- ++ ", because the package does not contain a "- ++ (case ecname of-      Left  _     -> "component"-      Right cname -> renderComponentKind Singular (componentKind cname))- ++ " with that name."--renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) =-    "Internal error when trying to " ++ verb ++ " the package "-  ++ prettyShow pkgid ++ ". The package is not in the set of available targets "-  ++ "for the project plan, which would suggest an inconsistency "-  ++ "between readTargetSelectors and resolveTargets."--renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) =-    "Internal error when trying to " ++ verb ++ " the "-  ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid-  ++ ". The package,component pair is not in the set of available targets "-  ++ "for the project plan, which would suggest an inconsistency "-  ++ "between readTargetSelectors and resolveTargets."------------------------------------------------------------------ Renderering error messages for TargetProblemNoneEnabled------- | Several commands have a @TargetProblemNoneEnabled@ problem constructor.--- This renders an error message for those cases.----renderTargetProblemNoneEnabled :: String-                               -> TargetSelector-                               -> [AvailableTarget ()]-                               -> String-renderTargetProblemNoneEnabled verb targetSelector targets =-    "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector- ++ " because none of the components are available to build: "- ++ renderListSemiAnd-    [ case (status, mstanza) of-        (TargetDisabledByUser, Just stanza) ->-            renderListCommaAnd-              [ "the " ++ showComponentName availableTargetComponentName-              | AvailableTarget {availableTargetComponentName} <- targets' ]-         ++ plural (listPlural targets') " is " " are "-         ++ " not available because building "-         ++ renderOptionalStanza Plural stanza-         ++ " has been disabled in the configuration"-        (TargetDisabledBySolver, Just stanza) ->-            renderListCommaAnd-              [ "the " ++ showComponentName availableTargetComponentName-              | AvailableTarget {availableTargetComponentName} <- targets' ]-         ++ plural (listPlural targets') " is " " are "-         ++ "not available because the solver did not find a plan that "-         ++ "included the " ++ renderOptionalStanza Plural stanza-         ++ ". Force the solver to enable this for all packages by adding the "-         ++ "line 'tests: True' to the 'cabal.project.local' file."-        (TargetNotBuildable, _) ->-            renderListCommaAnd-              [ "the " ++ showComponentName availableTargetComponentName-              | AvailableTarget {availableTargetComponentName} <- targets' ]-         ++ plural (listPlural targets') " is " " are all "-         ++ "marked as 'buildable: False'"-        (TargetNotLocal, _) ->-            renderListCommaAnd-              [ "the " ++ showComponentName availableTargetComponentName-              | AvailableTarget {availableTargetComponentName} <- targets' ]-         ++ " cannot be built because cabal does not currently support "-         ++ "building test suites or benchmarks of non-local dependencies"-        (TargetBuildable () TargetNotRequestedByDefault, Just stanza) ->-            renderListCommaAnd-              [ "the " ++ showComponentName availableTargetComponentName-              | AvailableTarget {availableTargetComponentName} <- targets' ]-         ++ " will not be built because " ++ renderOptionalStanza Plural stanza-         ++ " are not built by default in the current configuration (but you "-         ++ "can still build them specifically)" --TODO: say how-        _ -> error $ "renderBuildTargetProblem: unexpected status "-                  ++ show (status, mstanza)-    | ((status, mstanza), targets') <- sortGroupOn groupingKey targets-    ]-  where-    groupingKey t =-      ( availableTargetStatus t-      , case availableTargetStatus t of-          TargetNotBuildable -> Nothing-          TargetNotLocal     -> Nothing-          _ -> optionalStanza (availableTargetComponentName t)-      )----------------------------------------------------------------- Renderering error messages for TargetProblemNoneEnabled------- | Several commands have a @TargetProblemNoTargets@ problem constructor.--- This renders an error message for those cases.----renderTargetProblemNoTargets :: String -> TargetSelector -> String-renderTargetProblemNoTargets verb targetSelector =-    "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector- ++ " because " ++ reason targetSelector ++ ". "- ++ "Check the .cabal "- ++ plural (targetSelectorPluralPkgs targetSelector)-      "file for the package and make sure that it properly declares "-      "files for the packages and make sure that they properly declare "- ++ "the components that you expect."-  where-    reason (TargetPackage _ _ Nothing) =-        "it does not contain any components at all"-    reason (TargetPackage _ _ (Just kfilter)) =-        "it does not contain any " ++ renderComponentKind Plural kfilter-    reason (TargetPackageNamed _ Nothing) =-        "it does not contain any components at all"-    reason (TargetPackageNamed _ (Just kfilter)) =-        "it does not contain any " ++ renderComponentKind Plural kfilter-    reason (TargetAllPackages Nothing) =-        "none of them contain any components at all"-    reason (TargetAllPackages (Just kfilter)) =-        "none of the packages contain any "-     ++ renderComponentKind Plural kfilter-    reason ts@TargetComponent{} =-        error $ "renderTargetProblemNoTargets: " ++ show ts-    reason ts@TargetComponentUnknown{} =-        error $ "renderTargetProblemNoTargets: " ++ show ts---------------------------------------------------------------- Renderering error messages for CannotPruneDependencies-----renderCannotPruneDependencies :: CannotPruneDependencies -> String-renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =-      "Cannot select only the dependencies (as requested by the "-   ++ "'--only-dependencies' flag), "-   ++ (case pkgids of-          [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "-          _       -> "the packages "-                     ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ")-   ++ "required by a dependency of one of the other targets."-  where-    -- throw away the details and just list the deps that are needed-    pkgids :: [PackageId]-    pkgids = nub . map packageId . concatMap snd $ brokenPackages--{--           ++ "Syntax:\n"-           ++ " - build [package]\n"-           ++ " - build [package:]component\n"-           ++ " - build [package:][component:]module\n"-           ++ " - build [package:][component:]file\n"-           ++ " where\n"-           ++ "  package is a package name, package dir or .cabal file\n\n"-           ++ "Examples:\n"-           ++ " - build foo            -- package name\n"-           ++ " - build tests          -- component name\n"-           ++ "    (name of library, executable, test-suite or benchmark)\n"-           ++ " - build Data.Foo       -- module name\n"-           ++ " - build Data/Foo.hsc   -- file name\n\n"-           ++ "An ambigious target can be qualified by package, component\n"-           ++ "and/or component kind (lib|exe|test|bench|flib)\n"-           ++ " - build foo:tests      -- component qualified by package\n"-           ++ " - build tests:Data.Foo -- module qualified by component\n"-           ++ " - build lib:foo        -- component qualified by kind"--}
− Distribution/Client/CmdExec.hs 
@@ -1,251 +0,0 @@----------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Exec--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Implementation of the 'v2-exec' command for running an arbitrary executable--- in an environment suited to the part of the store built for a project.----------------------------------------------------------------------------------{-# LANGUAGE RecordWildCards #-}-module Distribution.Client.CmdExec-  ( execAction-  , execCommand-  ) where--import Distribution.Client.DistDirLayout-  ( DistDirLayout(..)-  )-import Distribution.Client.InstallPlan-  ( GenericPlanPackage(..)-  , toGraph-  )-import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-  ( ConfigFlags(configVerbosity)-  , GlobalFlags-  )-import Distribution.Client.ProjectOrchestration-  ( ProjectBuildContext(..)-  , runProjectPreBuildPhase-  , CurrentCommand(..)-  , establishProjectBaseContext-  , distDirLayout-  , commandLineFlagsToProjectConfig-  , ProjectBaseContext(..)-  )-import Distribution.Client.ProjectPlanOutput-  ( updatePostBuildProjectStatus-  , createPackageEnvironment-  , argsEquivalentOfGhcEnvironmentFile-  , PostBuildProjectStatus-  )-import qualified Distribution.Client.ProjectPlanning as Planning-import Distribution.Client.ProjectPlanning-  ( ElaboratedInstallPlan-  , ElaboratedSharedConfig(..)-  )-import Distribution.Simple.Command-  ( CommandUI(..), optionName-  )-import Distribution.Simple.Program.Db-  ( modifyProgramSearchPath-  , requireProgram-  , configuredPrograms-  )-import Distribution.Simple.Program.Find-  ( ProgramSearchPathEntry(..)-  )-import Distribution.Simple.Program.Run-  ( programInvocation-  , runProgramInvocation-  )-import Distribution.Simple.Program.Types-  ( programOverrideEnv-  , programDefaultArgs-  , programPath-  , simpleProgram-  , ConfiguredProgram-  )-import Distribution.Simple.GHC-  ( getImplInfo-  , GhcImplInfo(supportsPkgEnvFiles) )-import Distribution.Simple.Flag-  ( fromFlagOrDefault-  )-import Distribution.Simple.Utils-  ( die'-  , info-  , createDirectoryIfMissingVerbose-  , withTempDirectory-  , wrapText-  )-import Distribution.Verbosity-  ( normal-  )--import Prelude ()-import Distribution.Client.Compat.Prelude--import qualified Data.Set as S-import qualified Data.Map as M--execCommand :: CommandUI (NixStyleFlags ())-execCommand = CommandUI-  { commandName = "v2-exec"-  , commandSynopsis = "Give a command access to the store."-  , commandUsage = \pname ->-    "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n"-  , commandDescription = Just $ \pname -> wrapText $-       "During development it is often useful to run build tasks and perform"-    ++ " one-off program executions to experiment with the behavior of build"-    ++ " tools. It is convenient to run these tools in the same way " ++ pname-    ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to"-    ++ " do so.\n"-    ++ "\n"-    ++ "Compiler tools will be configured to see the same subset of the store"-    ++ " that builds would see. The PATH is modified to make all executables in"-    ++ " the dependency tree available (provided they have been built already)."-    ++ " Commands are also rewritten in the way cabal itself would. For"-    ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration"-    ++ " to choose an appropriate version of ghc and to include any"-    ++ " ghc-specific flags requested."-  , commandNotes = Nothing-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")-                        . nixStyleOptions (const [])-  , commandDefaultFlags = defaultNixStyleFlags ()-  }--execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-execAction flags@NixStyleFlags {..} extraArgs globalFlags = do--  baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--  -- To set up the environment, we'd like to select the libraries in our-  -- dependency tree that we've already built. So first we set up an install-  -- plan, but we walk the dependency tree without first executing the plan.-  buildCtx <- runProjectPreBuildPhase-    verbosity-    baseCtx-    (\plan -> return (plan, M.empty))--  -- We use the build status below to decide what libraries to include in the-  -- compiler environment, but we don't want to actually build anything. So we-  -- pass mempty to indicate that nothing happened and we just want the current-  -- status.-  buildStatus <- updatePostBuildProjectStatus-    verbosity-    (distDirLayout baseCtx)-    (elaboratedPlanOriginal buildCtx)-    (pkgsBuildStatus buildCtx)-    mempty--  -- Some dependencies may have executables. Let's put those on the PATH.-  extraPaths <- pathAdditions verbosity baseCtx buildCtx-  let programDb = modifyProgramSearchPath-                  (map ProgramSearchPathDir extraPaths ++)-                . pkgConfigCompilerProgs-                . elaboratedShared-                $ buildCtx--  -- Now that we have the packages, set up the environment. We accomplish this-  -- by creating an environment file that selects the databases and packages we-  -- computed in the previous step, and setting an environment variable to-  -- point at the file.-  -- In case ghc is too old to support environment files,-  -- we pass the same info as arguments-  let compiler = pkgConfigCompiler $ elaboratedShared buildCtx-      envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)-  case extraArgs of-    [] -> die' verbosity "Please specify an executable to run"-    exe:args -> do-      (program, _) <- requireProgram verbosity (simpleProgram exe) programDb-      let argOverrides =-            argsEquivalentOfGhcEnvironmentFile-              compiler-              (distDirLayout baseCtx)-              (elaboratedPlanOriginal buildCtx)-              buildStatus-          programIsConfiguredCompiler = matchCompilerPath-                                          (elaboratedShared buildCtx)-                                          program-          argOverrides' =-            if envFilesSupported-            || not programIsConfiguredCompiler-            then []-            else argOverrides--      (if envFilesSupported-      then withTempEnvFile verbosity baseCtx buildCtx buildStatus-      else \f -> f []) $ \envOverrides -> do-        let program'   = withOverrides-                           envOverrides-                           argOverrides'-                           program-            invocation = programInvocation program' args-        runProgramInvocation verbosity invocation-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags-                  mempty -- ClientInstallFlags, not needed here-    withOverrides env args program = program-      { programOverrideEnv = programOverrideEnv program ++ env-      , programDefaultArgs = programDefaultArgs program ++ args}--matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool-matchCompilerPath elaboratedShared program =-  programPath program-  `elem`-  (programPath <$> configuredCompilers)-  where-    configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared---- | Execute an action with a temporary .ghc.environment file reflecting the--- current environment. The action takes an environment containing the env--- variable which points ghc to the file.-withTempEnvFile :: Verbosity-                -> ProjectBaseContext-                -> ProjectBuildContext-                -> PostBuildProjectStatus-                -> ([(String, Maybe String)] -> IO a)-                -> IO a-withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do-  createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx))-  withTempDirectory-   verbosity-   (distTempDirectory (distDirLayout baseCtx))-   "environment."-   (\tmpDir -> do-     envOverrides <- createPackageEnvironment-       verbosity-       tmpDir-       (elaboratedPlanToExecute buildCtx)-       (elaboratedShared buildCtx)-       buildStatus-     action envOverrides)--pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath]-pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do-  info verbosity . unlines $ "Including the following directories in PATH:"-                           : paths-  return paths-  where-  paths = S.toList-        $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute--binDirectories-  :: DistDirLayout-  -> ElaboratedSharedConfig-  -> ElaboratedInstallPlan-  -> Set FilePath-binDirectories layout config = fromElaboratedInstallPlan where-  fromElaboratedInstallPlan = fromGraph . toGraph-  fromGraph = foldMap fromPlan-  fromSrcPkg = S.fromList . Planning.binDirectories layout config--  fromPlan (PreExisting _) = mempty-  fromPlan (Configured pkg) = fromSrcPkg pkg-  fromPlan (Installed pkg) = fromSrcPkg pkg-
− Distribution/Client/CmdFreeze.hs 
@@ -1,231 +0,0 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}---- | cabal-install CLI command: freeze----module Distribution.Client.CmdFreeze (-    freezeCommand,-    freezeAction,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.ProjectOrchestration-import Distribution.Client.ProjectPlanning-import Distribution.Client.ProjectConfig-         ( ProjectConfig(..), ProjectConfigShared(..)-         , writeProjectLocalFreezeConfig )-import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos)-import Distribution.Client.Targets-         ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )-import Distribution.Solver.Types.PackageConstraint-         ( PackageProperty(..) )-import Distribution.Solver.Types.ConstraintSource-         ( ConstraintSource(..) )-import Distribution.Client.DistDirLayout-         ( DistDirLayout(distProjectFile) )-import qualified Distribution.Client.InstallPlan as InstallPlan---import Distribution.Package-         ( PackageName, packageName, packageVersion )-import Distribution.Version-         ( VersionRange, thisVersion-         , unionVersionRanges, simplifyVersionRange )-import Distribution.PackageDescription-         ( FlagAssignment, nullFlagAssignment )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..) )-import Distribution.Simple.Flag-         ( fromFlagOrDefault )-import Distribution.Simple.Flag (Flag (..))-import Distribution.Simple.Utils-         ( die', notice, wrapText )-import Distribution.Verbosity-         ( normal )--import qualified Data.Map as Map--import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )--freezeCommand :: CommandUI (NixStyleFlags ())-freezeCommand = CommandUI {-  commandName         = "v2-freeze",-  commandSynopsis     = "Freeze dependencies.",-  commandUsage        = usageAlternatives "v2-freeze" [ "[FLAGS]" ],-  commandDescription  = Just $ \_ -> wrapText $-        "The project configuration is frozen so that it will be reproducible "-     ++ "in future.\n\n"--     ++ "The precise dependency configuration for the project is written to "-     ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "-     ++ "'--project-file' is specified). This file extends the configuration "-     ++ "from the 'cabal.project' file and thus is used as the project "-     ++ "configuration for all other commands (such as 'v2-build', "-     ++ "'v2-repl' etc).\n\n"--     ++ "The freeze file can be kept in source control. To make small "-     ++ "adjustments it may be edited manually, or to make bigger changes "-     ++ "you may wish to delete the file and re-freeze. For more control, "-     ++ "one approach is to try variations using 'v2-build --dry-run' with "-     ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "-     ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "-     ++ "with the same set of flags.",--  commandNotes        = Just $ \pname ->-        "Examples:\n"-     ++ "  " ++ pname ++ " v2-freeze\n"-     ++ "    Freeze the configuration of the current project\n\n"-     ++ "  " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"-     ++ "    Check what a solution with the given constraints would look like\n"-     ++ "  " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n"-     ++ "    Freeze a solution using the given constraints\n"--   , commandDefaultFlags = defaultNixStyleFlags ()-   , commandOptions      = nixStyleOptions (const [])-   }---- | To a first approximation, the @freeze@ command runs the first phase of--- the @build@ command where we bring the install plan up to date, and then--- based on the install plan we write out a @cabal.project.freeze@ config file.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do--    unless (null extraArgs) $-      die' verbosity $ "'freeze' doesn't take any extra arguments: "-         ++ unwords extraArgs--    ProjectBaseContext {-      distDirLayout,-      cabalDirLayout,-      projectConfig,-      localPackages-    } <- establishProjectBaseContext verbosity cliConfig OtherCommand--    (_, elaboratedPlan, _, totalIndexState, activeRepos) <--      rebuildInstallPlan verbosity-                         distDirLayout cabalDirLayout-                         projectConfig-                         localPackages--    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos-    writeProjectLocalFreezeConfig distDirLayout freezeConfig-    notice verbosity $-      "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"--  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags-                  mempty -- ClientInstallFlags, not needed here------ | Given the install plan, produce a config value with constraints that--- freezes the versions of packages used in the plan.----projectFreezeConfig-    :: ElaboratedInstallPlan-    -> TotalIndexState-    -> ActiveRepos-    -> ProjectConfig-projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty-    { projectConfigShared = mempty-        { projectConfigConstraints =-          concat (Map.elems (projectFreezeConstraints elaboratedPlan))-        , projectConfigIndexState  = Flag totalIndexState-        , projectConfigActiveRepos = Flag activeRepos-        }-    }-  where-    activeRepos :: ActiveRepos-    activeRepos = filterSkippedActiveRepos activeRepos0---- | Given the install plan, produce solver constraints that will ensure the--- solver picks the same solution again in future in different environments.----projectFreezeConstraints :: ElaboratedInstallPlan-                         -> Map PackageName [(UserConstraint, ConstraintSource)]-projectFreezeConstraints plan =-    ---    -- TODO: [required eventually] this is currently an underapproximation-    -- since the constraints language is not expressive enough to specify the-    -- precise solution. See https://github.com/haskell/cabal/issues/3502.-    ---    -- For the moment we deal with multiple versions in the solution by using-    -- constraints that allow either version. Also, we do not include any-    -- /version/ constraints for packages that are local to the project (e.g.-    -- if the solution has two instances of Cabal, one from the local project-    -- and one pulled in as a setup deps then we exclude all constraints on-    -- Cabal, not just the constraint for the local instance since any-    -- constraint would apply to both instances). We do however keep flag-    -- constraints of local packages.-    ---    deleteLocalPackagesVersionConstraints-      (Map.unionWith (++) versionConstraints flagConstraints)-  where-    versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]-    versionConstraints =-      Map.mapWithKey-        (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v),-                   ConstraintSourceFreeze)])-        versionRanges--    versionRanges :: Map PackageName VersionRange-    versionRanges =-      Map.map simplifyVersionRange $-      Map.fromListWith unionVersionRanges $-          [ (packageName pkg, thisVersion (packageVersion pkg))-          | InstallPlan.PreExisting pkg <- InstallPlan.toList plan-          ]-       ++ [ (packageName pkg, thisVersion (packageVersion pkg))-          | InstallPlan.Configured pkg <- InstallPlan.toList plan-          ]--    flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]-    flagConstraints =-      Map.mapWithKey-        (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f),-                   ConstraintSourceFreeze)])-        flagAssignments--    flagAssignments :: Map PackageName FlagAssignment-    flagAssignments =-      Map.fromList-        [ (pkgname, flags)-        | InstallPlan.Configured elab <- InstallPlan.toList plan-        , let flags   = elabFlagAssignment elab-              pkgname = packageName elab-        , not (nullFlagAssignment flags) ]--    -- As described above, remove the version constraints on local packages,-    -- but leave any flag constraints.-    deleteLocalPackagesVersionConstraints-      :: Map PackageName [(UserConstraint, ConstraintSource)]-      -> Map PackageName [(UserConstraint, ConstraintSource)]-    deleteLocalPackagesVersionConstraints =-      Map.mergeWithKey-        (\_pkgname () constraints ->-            case filter (not . isVersionConstraint . fst) constraints of-              []           -> Nothing-              constraints' -> Just constraints')-        (const Map.empty) id-        localPackages--    isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True-    isVersionConstraint _                                             = False--    localPackages :: Map PackageName ()-    localPackages =-      Map.fromList-        [ (packageName elab, ())-        | InstallPlan.Configured elab <- InstallPlan.toList plan-        , elabLocalToProject elab-        ]-
− Distribution/Client/CmdHaddock.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | cabal-install CLI command: haddock----module Distribution.Client.CmdHaddock (-    -- * The @haddock@ CLI and action-    haddockCommand,-    haddockAction,--    -- * Internals exposed for testing-    selectPackageTargets,-    selectComponentTarget-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.ProjectOrchestration-import Distribution.Client.CmdErrorMessages-import Distribution.Client.TargetProblem-         ( TargetProblem (..), TargetProblem' )-import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..) )-import Distribution.Simple.Setup-         ( HaddockFlags(..), fromFlagOrDefault )-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )-import Distribution.Verbosity-         ( normal )-import Distribution.Simple.Utils-         ( wrapText, die' )--haddockCommand :: CommandUI (NixStyleFlags ())-haddockCommand = CommandUI {-  commandName         = "v2-haddock",-  commandSynopsis     = "Build Haddock documentation",-  commandUsage        = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ],-  commandDescription  = Just $ \_ -> wrapText $-        "Build Haddock documentation for the specified packages within the "-     ++ "project.\n\n"--     ++ "Any package in the project can be specified. If no package is "-     ++ "specified, the default is to build the documentation for the package "-     ++ "in the current directory. The default behaviour is to build "-     ++ "documentation for the exposed modules of the library component (if "-     ++ "any). This can be changed with the '--internal', '--executables', "-     ++ "'--tests', '--benchmarks' or '--all' flags.\n\n"--     ++ "Currently, documentation for dependencies is NOT built. This "-     ++ "behavior may change in future.\n\n"--     ++ "Additional configuration flags can be specified on the command line "-     ++ "and these extend the project configuration from the 'cabal.project', "-     ++ "'cabal.project.local' and other files.",-  commandNotes        = Just $ \pname ->-        "Examples:\n"-     ++ "  " ++ pname ++ " v2-haddock pkgname"-     ++ "    Build documentation for the package named pkgname\n"-  , commandOptions      = nixStyleOptions (const [])-  , commandDefaultFlags = defaultNixStyleFlags ()-  }-   --TODO: [nice to have] support haddock on specific components, not just-   -- whole packages and the silly --executables etc modifiers.---- | The @haddock@ command is TODO.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do-    baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand--    targetSelectors <- either (reportTargetSelectorProblems verbosity) return-                   =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do--            when (buildSettingOnlyDeps (buildSettings baseCtx)) $-              die' verbosity-                "The haddock command does not support '--only-dependencies'."--              -- When we interpret the targets on the command line, interpret them as-              -- haddock targets-            targets <- either (reportBuildDocumentationTargetProblems verbosity) return-                     $ resolveTargets-                         (selectPackageTargets haddockFlags)-                         selectComponentTarget-                         elaboratedPlan-                         Nothing-                         targetSelectors--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionHaddock-                                    targets-                                    elaboratedPlan-            return (elaboratedPlan', targets)--    printPlan verbosity baseCtx buildCtx--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx-    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here---- | This defines what a 'TargetSelector' means for the @haddock@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @haddock@ command we select all buildable libraries. Additionally,--- depending on the @--executables@ flag we also select all the buildable exes.--- We do similarly for test-suites, benchmarks and foreign libs.----selectPackageTargets  :: HaddockFlags -> TargetSelector-                      -> [AvailableTarget k] -> Either TargetProblem' [k]-selectPackageTargets haddockFlags targetSelector targets--    -- If there are any buildable targets then we select those-  | not (null targetsBuildable)-  = Right targetsBuildable--    -- If there are targets but none are buildable then we report those-  | not (null targets)-  = Left (TargetProblemNoneEnabled targetSelector targets')--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    targets'         = forgetTargetsDetail    (map disableNotRequested targets)-    targetsBuildable = selectBuildableTargets (map disableNotRequested targets)--    -- When there's a target filter like "pkg:exes" then we do select exes,-    -- but if it's just a target like "pkg" then we don't build docs for exes-    -- unless they are requested by default (i.e. by using --executables)-    disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _)-      | not (isRequested targetSelector (componentKind cname))-      = t { availableTargetStatus = TargetDisabledByUser }-    disableNotRequested t = t--    isRequested (TargetPackage _ _ (Just _)) _ = True-    isRequested (TargetAllPackages (Just _)) _ = True-    isRequested _ LibKind    = True---  isRequested _ SubLibKind = True --TODO: what about sublibs?--    -- TODO/HACK, we encode some defaults here as v2-haddock's logic;-    -- make sure this matches the defaults applied in-    -- "Distribution.Client.ProjectPlanning"; this may need more work-    -- to be done properly-    ---    -- See also https://github.com/haskell/cabal/pull/4886-    isRequested _ FLibKind   = fromFlagOrDefault False (haddockForeignLibs haddockFlags)-    isRequested _ ExeKind    = fromFlagOrDefault False (haddockExecutables haddockFlags)-    isRequested _ TestKind   = fromFlagOrDefault False (haddockTestSuites  haddockFlags)-    isRequested _ BenchKind  = fromFlagOrDefault False (haddockBenchmarks  haddockFlags)----- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @haddock@ command we just need the basic checks on being buildable--- etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TargetProblem' k-selectComponentTarget = selectComponentTargetBasic--reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a-reportBuildDocumentationTargetProblems verbosity problems =-  reportTargetProblems verbosity "build documentation for" problems
− Distribution/Client/CmdInstall.hs 
@@ -1,960 +0,0 @@-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}---- | cabal-install CLI command: build----module Distribution.Client.CmdInstall (-    -- * The @build@ CLI and action-    installCommand,-    installAction,--    -- * Internals exposed for testing-    selectPackageTargets,-    selectComponentTarget,-    -- * Internals exposed for CmdRepl + CmdRun-    establishDummyDistDirLayout,-    establishDummyProjectBaseContext-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Distribution.Compat.Directory-         ( doesPathExist )--import Distribution.Client.ProjectOrchestration-import Distribution.Client.CmdErrorMessages-import Distribution.Client.CmdSdist-import Distribution.Client.TargetProblem-         ( TargetProblem', TargetProblem (..) )--import Distribution.Client.CmdInstall.ClientInstallFlags-import Distribution.Client.CmdInstall.ClientInstallTargetSelector--import Distribution.Client.Setup-         ( GlobalFlags(..), ConfigFlags(..) )-import Distribution.Client.Types-         ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage-         , SourcePackageDb(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Package-         ( Package(..), PackageName, mkPackageName, unPackageName )-import Distribution.Types.PackageId-         ( PackageIdentifier(..) )-import Distribution.Client.ProjectConfig-         ( ProjectPackageLocation(..)-         , fetchAndReadSourcePackages-         )-import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.ProjectFlags (ProjectFlags (..))-import Distribution.Client.ProjectConfig.Types-         ( ProjectConfig(..), ProjectConfigShared(..)-         , ProjectConfigBuildOnly(..), PackageConfig(..)-         , getMapLast, getMapMappend, projectConfigLogsDir-         , projectConfigStoreDir, projectConfigBuildOnly-         , projectConfigConfigFile )-import Distribution.Simple.Program.Db-         ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb-         , modifyProgramSearchPath, ProgramDb )-import Distribution.Simple.BuildPaths-         ( exeExtension )-import Distribution.Simple.Program.Find-         ( ProgramSearchPathEntry(..) )-import Distribution.Client.Config-         ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) )-import qualified Distribution.Simple.PackageIndex as PI-import Distribution.Solver.Types.PackageIndex-         ( lookupPackageName, searchByName )-import Distribution.Types.InstalledPackageInfo-         ( InstalledPackageInfo(..) )-import Distribution.Types.Version-         ( Version, nullVersion )-import Distribution.Types.VersionRange-         ( thisVersion )-import Distribution.Solver.Types.PackageConstraint-         ( PackageProperty(..) )-import Distribution.Client.IndexUtils-         ( getSourcePackages, getInstalledPackages )-import Distribution.Client.ProjectConfig-         ( projectConfigWithBuilderRepoContext-         , resolveBuildTimeSettings, withProjectOrGlobalConfig )-import Distribution.Client.ProjectPlanning-         ( storePackageInstallDirs' )-import Distribution.Client.ProjectPlanning.Types-         ( ElaboratedInstallPlan )-import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.Client.DistDirLayout-         ( DistDirLayout(..), mkCabalDirLayout-         , cabalStoreDirLayout-         , CabalDirLayout(..), StoreDirLayout(..) )-import Distribution.Client.RebuildMonad-         ( runRebuild )-import Distribution.Client.InstallSymlink-         ( symlinkBinary, trySymlink )-import Distribution.Client.Types.OverwritePolicy-         ( OverwritePolicy (..) )-import Distribution.Simple.Flag-         ( fromFlagOrDefault, flagToMaybe, flagElim )-import Distribution.Simple.Setup-         ( Flag(..) )-import Distribution.Solver.Types.SourcePackage-         ( SourcePackage(..) )-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )-import Distribution.Simple.Configure-         ( configCompilerEx )-import Distribution.Simple.Compiler-         ( Compiler(..), CompilerId(..), CompilerFlavor(..)-         , PackageDBStack )-import Distribution.Simple.GHC-         ( ghcPlatformAndVersionString, getGhcAppDir-         , GhcImplInfo(..), getImplInfo-         , GhcEnvironmentFileEntry(..)-         , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )-import Distribution.System-         ( Platform , buildOS, OS (Windows) )-import Distribution.Types.UnitId-         ( UnitId )-import Distribution.Types.UnqualComponentName-         ( UnqualComponentName, unUnqualComponentName )-import Distribution.Verbosity-         ( normal, lessVerbose )-import Distribution.Simple.Utils-         ( wrapText, die', notice, warn-         , withTempDirectory, createDirectoryIfMissingVerbose-         , ordNub )-import Distribution.Utils.Generic-         ( safeHead, writeFileAtomic )--import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Ord-         ( Down(..) )-import qualified Data.Map as Map-import Distribution.Utils.NubList-         ( fromNubList )-import Network.URI (URI)-import System.Directory-         ( doesFileExist, createDirectoryIfMissing-         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist-         , removeFile, removeDirectory, copyFile )-import System.FilePath-         ( (</>), (<.>), takeDirectory, takeBaseName )--installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)-installCommand = CommandUI-  { commandName         = "v2-install"-  , commandSynopsis     = "Install packages."-  , commandUsage        = usageAlternatives-                          "v2-install" [ "[TARGETS] [FLAGS]" ]-  , commandDescription  = Just $ \_ -> wrapText $-    "Installs one or more packages. This is done by installing them "-    ++ "in the store and symlinking/copying the executables in the directory "-    ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). "-    ++ "If you want the installed executables to be available globally, "-    ++ "make sure that the PATH environment variable contains that directory. "-    ++ "\n\n"-    ++ "If TARGET is a library, it will be added to the global environment. "-    ++ "When doing this, cabal will try to build a plan that includes all "-    ++ "the previously installed libraries. This is currently not implemented."-  , commandNotes        = Just $ \pname ->-      "Examples:\n"-      ++ "  " ++ pname ++ " v2-install\n"-      ++ "    Install the package in the current directory\n"-      ++ "  " ++ pname ++ " v2-install pkgname\n"-      ++ "    Install the package named pkgname"-      ++ " (fetching it from hackage if necessary)\n"-      ++ "  " ++ pname ++ " v2-install ./pkgfoo\n"-      ++ "    Install the package in the ./pkgfoo directory\n"--  , commandOptions      = nixStyleOptions clientInstallOptions-  , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags-  }---- | The @install@ command actually serves four different needs. It installs:--- * exes:---   For example a program from hackage. The behavior is similar to the old---   install command, except that now conflicts between separate runs of the---   command are impossible thanks to the store.---   Exes are installed in the store like a normal dependency, then they are---   symlinked/copied in the directory specified by --installdir.---   To do this we need a dummy projectBaseContext containing the targets as---   estra packages and using a temporary dist directory.--- * libraries---   Libraries install through a similar process, but using GHC environment---   files instead of symlinks. This means that 'v2-install'ing libraries---   only works on GHC >= 8.0.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()-installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do-  -- Ensure there were no invalid configuration options specified.-  verifyPreconditionsOrDie verbosity configFlags'--  -- We cannot use establishDummyProjectBaseContext to get these flags, since-  -- it requires one of them as an argument. Normal establishProjectBaseContext-  -- does not, and this is why this is done only for the install command-  clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'--  let-    installLibs    = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)-    targetFilter   = if installLibs then Just LibKind else Just ExeKind-    targetStrings' = if null targetStrings then ["."] else targetStrings--    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)-    withProject = do-      let reducedVerbosity = lessVerbose verbosity--      -- First, we need to learn about what's available to be installed.-      localBaseCtx <--        establishProjectBaseContext reducedVerbosity cliConfig InstallCommand-      let localDistDirLayout = distDirLayout localBaseCtx-      pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity-               (buildSettings localBaseCtx) (getSourcePackages verbosity)--      let-        (targetStrings'', packageIds) =-          partitionEithers .-          flip fmap targetStrings' $-          \str -> case simpleParsec str of-            Just (pkgId :: PackageId)-              | pkgVersion pkgId /= nullVersion -> Right pkgId-            _                                   -> Left str-        packageSpecifiers =-          flip fmap packageIds $ \case-          PackageIdentifier{..}-            | pkgVersion == nullVersion -> NamedPackage pkgName []-            | otherwise                 -> NamedPackage pkgName-                                           [PackagePropertyVersion-                                            (thisVersion pkgVersion)]-        packageTargets =-          flip TargetPackageNamed targetFilter . pkgName <$> packageIds--      if null targetStrings'-        then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)-        else do-          targetSelectors <--            either (reportTargetSelectorProblems verbosity) return-            =<< readTargetSelectors (localPackages localBaseCtx)-                                    Nothing targetStrings''--          (specs, selectors) <--            getSpecsAndTargetSelectors-              verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter--          return ( specs ++ packageSpecifiers-                 , []-                 , selectors ++ packageTargets-                 , projectConfig localBaseCtx )--    withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)-    withoutProject globalConfig = do-      tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'--      cabalDir <- getCabalDir-      let-        projectConfig = globalConfig <> cliConfig--        ProjectConfigBuildOnly {-          projectConfigLogsDir-        } = projectConfigBuildOnly projectConfig--        ProjectConfigShared {-          projectConfigStoreDir-        } = projectConfigShared projectConfig--        mlogsDir = flagToMaybe projectConfigLogsDir-        mstoreDir = flagToMaybe projectConfigStoreDir-        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir--        buildSettings = resolveBuildTimeSettings-                          verbosity cabalDirLayout-                          projectConfig--      SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext-                                            verbosity buildSettings-                                            (getSourcePackages verbosity)--      for_ (concatMap woPackageNames tss) $ \name -> do-        when (null (lookupPackageName packageIndex name)) $ do-          let xs = searchByName packageIndex (unPackageName name)-          let emptyIf True  _  = []-              emptyIf False zs = zs-          die' verbosity $ concat $-            [ "Unknown package \"", unPackageName name, "\". "-            ] ++ emptyIf (null xs)-            [ "Did you mean any of the following?\n"-            , unlines (("- " ++) . unPackageName . fst <$> xs)-            ]--      let-        (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss-        packageTargets            = map woPackageTargets tss--      return (packageSpecifiers, uris, packageTargets, projectConfig)--  (specs, uris, targetSelectors, config) <--     withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject--  let-    ProjectConfig {-      projectConfigBuildOnly = ProjectConfigBuildOnly {-        projectConfigLogsDir-      },-      projectConfigShared = ProjectConfigShared {-        projectConfigHcFlavor,-        projectConfigHcPath,-        projectConfigHcPkg,-        projectConfigStoreDir-      },-      projectConfigLocalPackages = PackageConfig {-        packageConfigProgramPaths,-        packageConfigProgramArgs,-        packageConfigProgramPathExtra-      }-    } = config--    hcFlavor = flagToMaybe projectConfigHcFlavor-    hcPath   = flagToMaybe projectConfigHcPath-    hcPkg    = flagToMaybe projectConfigHcPkg--    -- ProgramDb with directly user specified paths-    preProgDb =-        userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))-      . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))-      . modifyProgramSearchPath-          (++ [ ProgramSearchPathDir dir-              | dir <- fromNubList packageConfigProgramPathExtra ])-      $ defaultProgramDb--  -- progDb is a program database with compiler tools configured properly-  (compiler@Compiler { compilerId =-    compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <--      configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity--  let-    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler--  envFile <- getEnvFile clientInstallFlags platform compilerVersion-  existingEnvEntries <--    getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile-  packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir-  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb--  let-    (envSpecs, nonGlobalEnvEntries) =-      getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs--  -- Second, we need to use a fake project to let Cabal build the-  -- installables correctly. For that, we need a place to put a-  -- temporary dist directory.-  globalTmp <- getTemporaryDirectory--  withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do-    distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir--    uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages-      verbosity-      distDirLayout-      (projectConfigShared config)-      (projectConfigBuildOnly config)-      [ ProjectPackageRemoteTarball uri | uri <- uris ]--    baseCtx <- establishDummyProjectBaseContext-                 verbosity-                 config-                 distDirLayout-                 (envSpecs ++ specs ++ uriSpecs)-                 InstallCommand--    buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors--    printPlan verbosity baseCtx buildCtx--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx-    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes--    -- Now that we built everything we can do the installation part.-    -- First, figure out if / what parts we want to install:-    let-      dryRun = buildSettingDryRun $ buildSettings baseCtx--    -- Then, install!-    when (not dryRun) $-      if installLibs-      then installLibraries verbosity-           buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries-      else installExes verbosity-           baseCtx buildCtx platform compiler configFlags clientInstallFlags-  where-    configFlags' = disableTestsBenchsByDefault configFlags-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')-    ignoreProject = flagIgnoreProject projectFlags-    cliConfig = commandLineFlagsToProjectConfig-                  globalFlags-                  flags { configFlags = configFlags' }-                  clientInstallFlags'-    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)---- | Verify that invalid config options were not passed to the install command.------ If an invalid configuration is found the command will @die'@.-verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()-verifyPreconditionsOrDie verbosity configFlags = do-  -- We never try to build tests/benchmarks for remote packages.-  -- So we set them as disabled by default and error if they are explicitly-  -- enabled.-  when (configTests configFlags == Flag True) $-    die' verbosity $ "--enable-tests was specified, but tests can't "-                  ++ "be enabled in a remote package"-  when (configBenchmarks configFlags == Flag True) $-    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "-                  ++ "be enabled in a remote package"--getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags-getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do-  let configFileFlag = globalConfigFile globalFlags-  savedConfig <- loadConfig verbosity configFileFlag-  pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags---getSpecsAndTargetSelectors-  :: Verbosity-  -> Verbosity-  -> SourcePackageDb-  -> [TargetSelector]-  -> DistDirLayout-  -> ProjectBaseContext-  -> Maybe ComponentKindFilter-  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])-getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =-  withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do-  -- Split into known targets and hackage packages.-  (targets, hackageNames) <--    partitionToKnownTargetsAndHackagePackages-      verbosity pkgDb elaboratedPlan targetSelectors--  let-    planMap = InstallPlan.toMap elaboratedPlan-    targetIds = Map.keys targets--    sdistize (SpecificSourcePackage spkg) =-      SpecificSourcePackage spkg'-      where-        sdistPath = distSdistFile localDistDirLayout (packageId spkg)-        spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath }-    sdistize named = named--    local = sdistize <$> localPackages localBaseCtx--    gatherTargets :: UnitId -> TargetSelector-    gatherTargets targetId = TargetPackageNamed pkgName targetFilter-      where-        targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap-        PackageIdentifier{..} = packageId targetUnit--    targets' = fmap gatherTargets targetIds--    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]-    hackagePkgs = flip NamedPackage [] <$> hackageNames--    hackageTargets :: [TargetSelector]-    hackageTargets =-      flip TargetPackageNamed targetFilter <$> hackageNames--  createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)--  unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of-      SpecificSourcePackage pkg -> packageToSdist verbosity-        (distProjectRootDirectory localDistDirLayout) TarGzArchive-        (distSdistFile localDistDirLayout (packageId pkg)) pkg-      NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName--  if null targets-    then return (hackagePkgs, hackageTargets)-    else return (local ++ hackagePkgs, targets' ++ hackageTargets)---- | Partitions the target selectors into known local targets and hackage packages.-partitionToKnownTargetsAndHackagePackages-  :: Verbosity-  -> SourcePackageDb-  -> ElaboratedInstallPlan-  -> [TargetSelector]-  -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName])-partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do-  let mTargets = resolveTargets-        selectPackageTargets-        selectComponentTarget-        elaboratedPlan-        (Just pkgDb)-        targetSelectors-  case mTargets of-    Right targets ->-      -- Everything is a local dependency.-      return (targets, [])-    Left errs     -> do-      -- Not everything is local.-      let-        (errs', hackageNames) = partitionEithers . flip fmap errs $ \case-          TargetAvailableInIndex name -> Right name-          err                         -> Left err--      -- report incorrect case for known package.-      for_ errs' $ \case-        TargetNotInProject hn ->-          case searchByName (packageIndex pkgDb) (unPackageName hn) of-            [] -> return ()-            xs -> die' verbosity . concat $-              [ "Unknown package \"", unPackageName hn, "\". "-              , "Did you mean any of the following?\n"-              , unlines (("- " ++) . unPackageName . fst <$> xs)-              ]-        _ -> return ()--      when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'--      let-        targetSelectors' = flip filter targetSelectors $ \case-          TargetComponentUnknown name _ _-            | name `elem` hackageNames -> False-          TargetPackageNamed name _-            | name `elem` hackageNames -> False-          _                            -> True--      -- This can't fail, because all of the errors are-      -- removed (or we've given up).-      targets <--        either (reportBuildTargetProblems verbosity) return $-        resolveTargets-          selectPackageTargets-          selectComponentTarget-          elaboratedPlan-          Nothing-          targetSelectors'--      return (targets, hackageNames)----constructProjectBuildContext-  :: Verbosity-  -> ProjectBaseContext-     -- ^ The synthetic base context to use to produce the full build context.-  -> [TargetSelector]-  -> IO ProjectBuildContext-constructProjectBuildContext verbosity baseCtx targetSelectors = do-  runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do-    -- Interpret the targets on the command line as build targets-    targets <- either (reportBuildTargetProblems verbosity) return $-      resolveTargets-        selectPackageTargets-        selectComponentTarget-        elaboratedPlan-        Nothing-        targetSelectors--    let prunedToTargetsElaboratedPlan =-          pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan-    prunedElaboratedPlan <--      if buildSettingOnlyDeps (buildSettings baseCtx)-      then either (reportCannotPruneDependencies verbosity) return $-           pruneInstallPlanToDependencies (Map.keysSet targets)-                                          prunedToTargetsElaboratedPlan-      else return prunedToTargetsElaboratedPlan--    return (prunedElaboratedPlan, targets)----- | Install any built exe by symlinking/copying it--- we don't use BuildOutcomes because we also need the component names-installExes-  :: Verbosity-  -> ProjectBaseContext-  -> ProjectBuildContext-  -> Platform-  -> Compiler-  -> ConfigFlags-  -> ClientInstallFlags-  -> IO ()-installExes verbosity baseCtx buildCtx platform compiler-            configFlags clientInstallFlags = do-  installPath <- defaultInstallPath-  let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx--      prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))-      suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))--      mkUnitBinDir :: UnitId -> FilePath-      mkUnitBinDir =-        InstallDirs.bindir .-        storePackageInstallDirs' storeDirLayout (compilerId compiler)--      mkExeName :: UnqualComponentName -> FilePath-      mkExeName exe = unUnqualComponentName exe <.> exeExtension platform--      mkFinalExeName :: UnqualComponentName -> FilePath-      mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform-      installdirUnknown =-        "installdir is not defined. Set it in your cabal config file "-        ++ "or use --installdir=<path>. Using default installdir: " ++ show installPath--  installdir <- fromFlagOrDefault-                (warn verbosity installdirUnknown >> pure installPath) $-                pure <$> cinstInstalldir clientInstallFlags-  createDirectoryIfMissingVerbose verbosity False installdir-  warnIfNoExes verbosity buildCtx--  installMethod <- flagElim defaultMethod return $-    cinstInstallMethod clientInstallFlags--  let-    doInstall = installUnitExes-                  verbosity-                  overwritePolicy-                  mkUnitBinDir mkExeName mkFinalExeName-                  installdir installMethod-    in traverse_ doInstall $ Map.toList $ targetsMap buildCtx-  where-    overwritePolicy = fromFlagOrDefault NeverOverwrite $-                      cinstOverwritePolicy clientInstallFlags-    isWindows = buildOS == Windows--    -- This is in IO as we will make environment checks,-    -- to decide which method is best-    defaultMethod :: IO InstallMethod-    defaultMethod-      -- Try symlinking in temporary directory, if it works default to-      -- symlinking even on windows-      | isWindows = do-        symlinks <- trySymlink verbosity-        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy-      | otherwise = return InstallMethodSymlink---- | Install any built library by adding it to the default ghc environment-installLibraries-  :: Verbosity-  -> ProjectBuildContext-  -> Compiler-  -> PackageDBStack-  -> ProgramDb-  -> FilePath -- ^ Environment file-  -> [GhcEnvironmentFileEntry]-  -> IO ()-installLibraries verbosity buildCtx compiler-                 packageDbs programDb envFile envEntries = do-  -- Why do we get it again? If we updated a globalPackage then we need-  -- the new version.-  installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb-  if supportsPkgEnvFiles $ getImplInfo compiler-    then do-      let-        getLatest :: PackageName -> [InstalledPackageInfo]-        getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst))-                  . PI.lookupPackageName installedIndex-        globalLatest = concat (getLatest <$> globalPackages)--        baseEntries =-          GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs-        globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest-        pkgEntries = ordNub $-              globalEntries-          ++ envEntries-          ++ entriesForLibraryComponents (targetsMap buildCtx)-        contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)-      createDirectoryIfMissing True (takeDirectory envFile)-      writeFileAtomic envFile (BS.pack contents')-    else-      warn verbosity $-          "The current compiler doesn't support safely installing libraries, "-        ++ "so only executables will be available. (Library installation is "-        ++ "supported on GHC 8.0+ only)"--warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()-warnIfNoExes verbosity buildCtx =-  when noExes $-    warn verbosity $-    "\n" <>-    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>-    "@ WARNING: Installation might not be completed as desired! @\n" <>-    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>-    "Without flags, the command \"cabal install\" doesn't expose" <>-    " libraries in a usable manner.  You might have wanted to run" <>-    " \"cabal install --lib " <>-    unwords (showTargetSelector <$> selectors) <> "\". "-  where-    targets    = concat $ Map.elems $ targetsMap buildCtx-    components = fst <$> targets-    selectors  = concatMap snd targets-    noExes     = null $ catMaybes $ exeMaybe <$> components--    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe-    exeMaybe _                                  = Nothing--globalPackages :: [PackageName]-globalPackages = mkPackageName <$>-  [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath"-  , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary"-  , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq"-  , "ghc-boot-th", "pretty", "template-haskell", "directory", "text"-  , "bin-package-db"-  ]---- | Return the package specifiers and non-global environment file entries.-getEnvSpecsAndNonGlobalEntries-  :: PI.InstalledPackageIndex-  -> [GhcEnvironmentFileEntry]-  -> Bool-  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])-getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =-  if installLibs-  then (envSpecs, envEntries')-  else ([], envEntries')-  where-    (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries--environmentFileToSpecifiers-  :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]-  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])-environmentFileToSpecifiers ipi = foldMap $ \case-    (GhcEnvFilePackageId unitId)-        | Just InstalledPackageInfo-          { sourcePackageId = PackageIdentifier{..}, installedUnitId }-          <- PI.lookupUnitId ipi unitId-        , let pkgSpec = NamedPackage pkgName-                        [PackagePropertyVersion (thisVersion pkgVersion)]-        -> if pkgName `elem` globalPackages-          then ([pkgSpec], [])-          else ([pkgSpec], [GhcEnvFilePackageId installedUnitId])-    _ -> ([], [])----- | Disables tests and benchmarks if they weren't explicitly enabled.-disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags-disableTestsBenchsByDefault configFlags =-  configFlags { configTests = Flag False <> configTests configFlags-              , configBenchmarks = Flag False <> configBenchmarks configFlags }---- | Symlink/copy every exe from a package from the store to a given location-installUnitExes-  :: Verbosity-  -> OverwritePolicy -- ^ Whether to overwrite existing files-  -> (UnitId -> FilePath) -- ^ A function to get an UnitId's-                          -- ^ store directory-  -> (UnqualComponentName -> FilePath) -- ^ A function to get an-                                       -- ^ exe's filename-  -> (UnqualComponentName -> FilePath) -- ^ A function to get an-                                       -- ^ exe's final possibly-                                       -- ^ different to the name in the store.-  -> FilePath-  -> InstallMethod-  -> ( UnitId-     , [(ComponentTarget, [TargetSelector])] )-  -> IO ()-installUnitExes verbosity overwritePolicy-                mkSourceBinDir mkExeName mkFinalExeName-                installdir installMethod-                (unit, components) =-  traverse_ installAndWarn exes-  where-    exes = catMaybes $ (exeMaybe . fst) <$> components-    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe-    exeMaybe _ = Nothing-    installAndWarn exe = do-      success <- installBuiltExe-                   verbosity overwritePolicy-                   (mkSourceBinDir unit) (mkExeName exe)-                   (mkFinalExeName exe)-                   installdir installMethod-      let errorMessage = case overwritePolicy of-            NeverOverwrite ->-              "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "-              <> "Use --overwrite-policy=always to overwrite."-            -- This shouldn't even be possible, but we keep it in case-            -- symlinking/copying logic changes-            AlwaysOverwrite ->-              case installMethod of-                InstallMethodSymlink -> "Symlinking"-                InstallMethodCopy    ->-                  "Copying" <> " '" <> prettyShow exe <> "' failed."-      unless success $ die' verbosity errorMessage---- | Install a specific exe.-installBuiltExe-  :: Verbosity -> OverwritePolicy-  -> FilePath -- ^ The directory where the built exe is located-  -> FilePath -- ^ The exe's filename-  -> FilePath -- ^ The exe's filename in the public install directory-  -> FilePath -- ^ the directory where it should be installed-  -> InstallMethod-  -> IO Bool -- ^ Whether the installation was successful-installBuiltExe verbosity overwritePolicy-                sourceDir exeName finalExeName-                installdir InstallMethodSymlink = do-  notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"-  symlinkBinary-    overwritePolicy-    installdir-    sourceDir-    finalExeName-    exeName-  where-    destination = installdir </> finalExeName-installBuiltExe verbosity overwritePolicy-                sourceDir exeName finalExeName-                installdir InstallMethodCopy = do-  notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"-  exists <- doesPathExist destination-  case (exists, overwritePolicy) of-    (True , NeverOverwrite ) -> pure False-    (True , AlwaysOverwrite) -> remove >> copy-    (False, _              ) -> copy-  where-    source      = sourceDir </> exeName-    destination = installdir </> finalExeName-    remove = do-      isDir <- doesDirectoryExist destination-      if isDir-      then removeDirectory destination-      else removeFile      destination-    copy = copyFile source destination >> pure True---- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.-entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]-entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []-  where-    hasLib :: (ComponentTarget, [TargetSelector]) -> Bool-    hasLib (ComponentTarget (CLibName _) _, _) = True-    hasLib _                                   = False--    go :: UnitId-       -> [(ComponentTarget, [TargetSelector])]-       -> [GhcEnvironmentFileEntry]-    go unitId targets-      | any hasLib targets = [GhcEnvFilePackageId unitId]-      | otherwise          = []----- | Gets the file path to the request environment file.-getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath-getEnvFile clientInstallFlags platform compilerVersion = do-  appDir <- getGhcAppDir-  case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of-    Just spec-      -- Is spec a bare word without any "pathy" content, then it refers to-      -- a named global environment.-      | takeBaseName spec == spec ->-          return (getGlobalEnv appDir platform compilerVersion spec)-      | otherwise                 -> do-        spec' <- makeAbsolute spec-        isDir <- doesDirectoryExist spec'-        if isDir-          -- If spec is a directory, then make an ambient environment inside-          -- that directory.-          then return (getLocalEnv spec' platform compilerVersion)-          -- Otherwise, treat it like a literal file path.-          else return spec'-    Nothing                       ->-      return (getGlobalEnv appDir platform compilerVersion "default")---- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the---   environment being operated on.-getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]-getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do-  envFileExists <- doesFileExist envFile-  filterEnvEntries <$> if-    (compilerFlavor == GHC || compilerFlavor == GHCJS)-      && supportsPkgEnvFiles && envFileExists-    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->-      warn verbosity ("The environment file " ++ envFile ++-        " is unparsable. Libraries cannot be installed.") >> return []-    else return []-  where-    -- Why? We know what the first part will be, we only care about the packages.-    filterEnvEntries = filter $ \case-      GhcEnvFilePackageId _ -> True-      _                     -> False---- | Constructs the path to the global GHC environment file.------ TODO(m-renaud): Create PkgEnvName newtype wrapper.-getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath-getGlobalEnv appDir platform compilerVersion name =-  appDir </> ghcPlatformAndVersionString platform compilerVersion-  </> "environments" </> name---- | Constructs the path to a local GHC environment file.-getLocalEnv :: FilePath -> Platform -> Version -> FilePath-getLocalEnv dir platform compilerVersion  =-  dir </>-  ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion--getPackageDbStack-  :: CompilerId-  -> Flag FilePath-  -> Flag FilePath-  -> IO PackageDBStack-getPackageDbStack compilerId storeDirFlag logsDirFlag = do-  cabalDir <- getCabalDir-  mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag-  let-    mlogsDir    = flagToMaybe logsDirFlag-    cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir-  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId---- | This defines what a 'TargetSelector' means for the @bench@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @build@ command select all components except non-buildable--- and disabled tests\/benchmarks, fail if there are no such--- components----selectPackageTargets-  :: TargetSelector-  -> [AvailableTarget k] -> Either TargetProblem' [k]-selectPackageTargets targetSelector targets--    -- If there are any buildable targets then we select those-  | not (null targetsBuildable)-  = Right targetsBuildable--    -- If there are targets but none are buildable then we report those-  | not (null targets)-  = Left (TargetProblemNoneEnabled targetSelector targets')--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    targets'         = forgetTargetsDetail targets-    targetsBuildable = selectBuildableTargetsWith-                         (buildable targetSelector)-                         targets--    -- When there's a target filter like "pkg:tests" then we do select tests,-    -- but if it's just a target like "pkg" then we don't build tests unless-    -- they are requested by default (i.e. by using --enable-tests)-    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False-    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False-    buildable _ _ = True---- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @build@ command we just need the basic checks on being buildable etc.----selectComponentTarget-  :: SubComponentTarget-  -> AvailableTarget k -> Either TargetProblem' k-selectComponentTarget = selectComponentTargetBasic--reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a-reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems--reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a-reportCannotPruneDependencies verbosity =-    die' verbosity . renderCannotPruneDependencies
− Distribution/Client/CmdInstall/ClientInstallFlags.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-module Distribution.Client.CmdInstall.ClientInstallFlags-( InstallMethod(..)-, ClientInstallFlags(..)-, defaultClientInstallFlags-, clientInstallOptions-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.ReadE-         ( succeedReadE, parsecToReadE )-import Distribution.Simple.Command-         ( ShowOrParseArgs(..), OptionField(..), option, reqArg )-import Distribution.Simple.Setup-         ( Flag(..), trueArg, flagToList, toFlag )--import Distribution.Client.Types.InstallMethod-         ( InstallMethod (..) )-import Distribution.Client.Types.OverwritePolicy-         ( OverwritePolicy(..) )--import qualified Distribution.Compat.CharParsing as P--data ClientInstallFlags = ClientInstallFlags-  { cinstInstallLibs     :: Flag Bool-  , cinstEnvironmentPath :: Flag FilePath-  , cinstOverwritePolicy :: Flag OverwritePolicy-  , cinstInstallMethod   :: Flag InstallMethod-  , cinstInstalldir      :: Flag FilePath-  } deriving (Eq, Show, Generic)--instance Monoid ClientInstallFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ClientInstallFlags where-  (<>) = gmappend--instance Binary ClientInstallFlags-instance Structured ClientInstallFlags--defaultClientInstallFlags :: ClientInstallFlags-defaultClientInstallFlags = ClientInstallFlags-  { cinstInstallLibs     = toFlag False-  , cinstEnvironmentPath = mempty-  , cinstOverwritePolicy = mempty-  , cinstInstallMethod   = mempty-  , cinstInstalldir      = mempty-  }--clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]-clientInstallOptions _ =-  [ option [] ["lib"]-    "Install libraries rather than executables from the target package."-    cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v })-    trueArg-  , option [] ["package-env", "env"]-    "Set the environment file that may be modified."-    cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })-    (reqArg "ENV" (succeedReadE Flag) flagToList)-  , option [] ["overwrite-policy"]-    "How to handle already existing symlinks."-    cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })-    $ reqArg "always|never"-        (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) -        (map prettyShow . flagToList)-  , option [] ["install-method"]-    "How to install the executables."-    cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })-    $ reqArg-        "default|copy|symlink"-        (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod))-        (map prettyShow . flagToList)-  , option [] ["installdir"]-    "Where to install (by symlinking or copying) the executables in."-    cinstInstalldir (\v flags -> flags { cinstInstalldir = v })-    $ reqArg "DIR" (succeedReadE Flag) flagToList-  ]--parsecInstallMethod :: CabalParsing m => m InstallMethod-parsecInstallMethod = do-    name <- P.munch1 isAlpha-    case name of-        "copy"    -> pure InstallMethodCopy-        "symlink" -> pure InstallMethodSymlink-        _         -> P.unexpected $ "InstallMethod: " ++ name
− Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs 
@@ -1,68 +0,0 @@-module Distribution.Client.CmdInstall.ClientInstallTargetSelector (-    WithoutProjectTargetSelector (..),-    parseWithoutProjectTargetSelector,-    woPackageNames,-    woPackageTargets,-    woPackageSpecifiers,-    ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Network.URI (URI, parseURI)--import Distribution.Client.TargetSelector-import Distribution.Client.Types-import Distribution.Compat.CharParsing             (char, optional)-import Distribution.Package-import Distribution.Simple.LocalBuildInfo          (ComponentName (CExeName))-import Distribution.Simple.Utils                   (die')-import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))-import Distribution.Version--data WithoutProjectTargetSelector-    = WoPackageId PackageId-    | WoPackageComponent PackageId ComponentName-    | WoURI URI-  deriving (Show)--parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector-parseWithoutProjectTargetSelector verbosity input =-    case explicitEitherParsec parser input of-        Right ts -> return ts-        Left err -> case parseURI input of-            Just uri -> return (WoURI uri)-            Nothing  -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err-  where-    parser :: CabalParsing m => m WithoutProjectTargetSelector-    parser = do-        pid <- parsec-        cn  <- optional (char ':' *> parsec)-        return $ case cn of-            Nothing -> WoPackageId pid-            Just cn' -> WoPackageComponent pid (CExeName cn')--woPackageNames  :: WithoutProjectTargetSelector -> [PackageName]-woPackageNames (WoPackageId pid)          = [pkgName pid]-woPackageNames (WoPackageComponent pid _) = [pkgName pid]-woPackageNames (WoURI _)                  = []--woPackageTargets  :: WithoutProjectTargetSelector -> TargetSelector-woPackageTargets (WoPackageId pid) =-    TargetPackageNamed (pkgName pid) Nothing-woPackageTargets (WoPackageComponent pid cn) =-    TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent-woPackageTargets (WoURI _) =-    TargetAllPackages (Just ExeKind)--woPackageSpecifiers  :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)-woPackageSpecifiers (WoPackageId pid)          = Right (pidPackageSpecifiers pid)-woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid)-woPackageSpecifiers (WoURI uri)                = Left uri--pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg-pidPackageSpecifiers pid-    | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []-    | otherwise                     = NamedPackage (pkgName pid)-        [ PackagePropertyVersion (thisVersion (pkgVersion pid))-        ]
− Distribution/Client/CmdLegacy.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.Sandbox-    ( loadConfigOrSandboxConfig, findSavedDistPref )-import qualified Distribution.Client.Setup as Client-import Distribution.Client.SetupWrapper-    ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions )-import qualified Distribution.Simple.Setup as Setup-import Distribution.Simple.Command-import Distribution.Simple.Utils-    ( wrapText )-import Distribution.Verbosity-    ( normal )--import Control.Exception-    ( try )-import qualified Data.Text as T---- Tweaked versions of code from Main.-regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action)-regularCmd ui action =-        CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand--wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ())-wrapperCmd ui verbosity' distPref =-  CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand--wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ())-wrapperAction command verbosityFlag distPrefFlag =-  commandAddAction command-    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do-    let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags)--    load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)-    let config = either (\(SomeException _) -> mempty) id load-    distPref <- findSavedDistPref config (distPrefFlag flags)-    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }--    let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command }--    setupWrapper verbosity' setupScriptOptions Nothing-                 command' (const flags) (const extraArgs)------class HasVerbosity a where-    verbosity :: a -> Verbosity--instance HasVerbosity (Setup.Flag Verbosity) where-    verbosity = Setup.fromFlagOrDefault normal--instance (HasVerbosity a) => HasVerbosity (a, b) where-    verbosity (a, _) = verbosity a--instance (HasVerbosity a) => HasVerbosity (a, b, c) where-    verbosity (a , _, _) = verbosity a--instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where-    verbosity (a, _, _, _) = verbosity a--instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where-    verbosity (a, _, _, _, _) = verbosity a--instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where-    verbosity (a, _, _, _, _, _) = verbosity a--instance HasVerbosity Setup.BuildFlags where-    verbosity = verbosity . Setup.buildVerbosity--instance HasVerbosity Setup.ConfigFlags where-    verbosity = verbosity . Setup.configVerbosity--instance HasVerbosity Setup.ReplFlags where-    verbosity = verbosity . Setup.replVerbosity--instance HasVerbosity Client.FreezeFlags where-    verbosity = verbosity . Client.freezeVerbosity--instance HasVerbosity Setup.HaddockFlags where-    verbosity = verbosity . Setup.haddockVerbosity--instance HasVerbosity Client.ExecFlags where-    verbosity = verbosity . Client.execVerbosity--instance HasVerbosity Client.UpdateFlags where-    verbosity = verbosity . Client.updateVerbosity--instance HasVerbosity Setup.CleanFlags where-    verbosity = verbosity . Setup.cleanVerbosity--instance HasVerbosity Setup.DoctestFlags where-    verbosity = verbosity . Setup.doctestVerbosity------legacyNote :: String -> String-legacyNote cmd = wrapText $-    "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++--    "It is a legacy feature and will be removed in a future release of cabal-install." ++-    " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++-    " commands.\n\n" ++--    "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"--toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)]-toLegacyCmd mkSpec = [toLegacy mkSpec]-  where-    toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type'-      where-        legUi = origUi-            { commandName = "v1-" ++ commandName-            , commandNotes = Just $ \pname -> case commandNotes of-                Just notes -> notes pname ++ "\n" ++ legacyNote commandName-                Nothing -> legacyNote commandName-            }--legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]-legacyCmd ui action = toLegacyCmd (regularCmd ui action)--legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())]-legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref)--newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]-newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi]-    where-        cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand--        newMsg = T.unpack . T.replace "v2-" "new-" . T.pack-        newUi = origUi-            { commandName = newMsg commandName-            , commandUsage = newMsg . commandUsage-            , commandDescription = (newMsg .) <$> commandDescription-            , commandNotes = (newMsg .) <$> commandNotes-            }--        defaultMsg = T.unpack . T.replace "v2-" "" . T.pack-        defaultUi = origUi-            { commandName = defaultMsg commandName-            , commandUsage = defaultMsg . commandUsage-            , commandDescription = (defaultMsg .) <$> commandDescription-            , commandNotes = (defaultMsg .) <$> commandNotes-            }
− Distribution/Client/CmdListBin.hs 
@@ -1,368 +0,0 @@-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TupleSections     #-}-module Distribution.Client.CmdListBin (-    listbinCommand,-    listbinAction,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.CmdErrorMessages-       (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets,-       renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs)-import Distribution.Client.DistDirLayout         (DistDirLayout (..), ProjectRoot (..))-import Distribution.Client.NixStyleOptions-       (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions)-import Distribution.Client.ProjectConfig-       (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig)-import Distribution.Client.ProjectFlags          (ProjectFlags (..))-import Distribution.Client.ProjectOrchestration-import Distribution.Client.ProjectPlanning.Types-import Distribution.Client.Setup                 (GlobalFlags (..))-import Distribution.Client.TargetProblem         (TargetProblem (..))-import Distribution.Simple.BuildPaths            (dllExtension, exeExtension)-import Distribution.Simple.Command               (CommandUI (..))-import Distribution.Simple.Setup                 (configVerbosity, fromFlagOrDefault)-import Distribution.Simple.Utils                 (die', ordNub, wrapText)-import Distribution.System                       (Platform)-import Distribution.Types.ComponentName          (showComponentName)-import Distribution.Types.UnitId                 (UnitId)-import Distribution.Types.UnqualComponentName    (UnqualComponentName)-import Distribution.Verbosity                    (silent, verboseStderr)-import System.Directory                          (getCurrentDirectory)-import System.FilePath                           ((<.>), (</>))--import qualified Data.Map                                as Map-import qualified Data.Set                                as Set-import qualified Distribution.Client.InstallPlan         as IP-import qualified Distribution.Simple.InstallDirs         as InstallDirs-import qualified Distribution.Solver.Types.ComponentDeps as CD------------------------------------------------------------------------------------ Command----------------------------------------------------------------------------------listbinCommand :: CommandUI (NixStyleFlags ())-listbinCommand = CommandUI-    { commandName = "list-bin"-    , commandSynopsis = "list path to a single executable."-    , commandUsage = \pname ->-        "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n"-    , commandDescription  = Just $ \_ -> wrapText-        "List path to a build product."-    , commandNotes = Nothing-    , commandDefaultFlags = defaultNixStyleFlags ()-    , commandOptions      = nixStyleOptions (const [])-    }------------------------------------------------------------------------------------ Action----------------------------------------------------------------------------------listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-listbinAction flags@NixStyleFlags{..} args globalFlags = do-    -- fail early if multiple target selectors specified-    target <- case args of-        []  -> die' verbosity "One target is required, none provided"-        [x] -> return x-        _   -> die' verbosity "One target is required, given multiple"--    -- configure-    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject-    let localPkgs = localPackages baseCtx--    -- elaborate target selectors-    targetSelectors <- either (reportTargetSelectorProblems verbosity) return-        =<< readTargetSelectors localPkgs Nothing [target]--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do-            -- Interpret the targets on the command line as build targets-            -- (as opposed to say repl or haddock targets).-            targets <- either (reportTargetProblems verbosity) return-                     $ resolveTargets-                         selectPackageTargets-                         selectComponentTarget-                         elaboratedPlan-                         Nothing-                         targetSelectors--            -- Reject multiple targets, or at least targets in different-            -- components. It is ok to have two module/file targets in the-            -- same component, but not two that live in different components.-            ---            -- Note that we discard the target and return the whole 'TargetsMap',-            -- so this check will be repeated (and must succeed) after-            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.-            _ <- singleComponentOrElse-                   (reportTargetProblems-                      verbosity-                      [multipleTargetsProblem targets])-                   targets--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionBuild-                                    targets-                                    elaboratedPlan-            return (elaboratedPlan', targets)--    (selectedUnitId, _selectedComponent) <--      -- Slight duplication with 'runProjectPreBuildPhase'.-      singleComponentOrElse-        (die' verbosity $ "No or multiple targets given, but the run "-                       ++ "phase has been reached. This is a bug.")-        $ targetsMap buildCtx--    printPlan verbosity baseCtx buildCtx--    binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of-        Nothing  -> die' verbosity "No or multiple targets given..."-        Just gpp -> return $ IP.foldPlanPackage-            (const []) -- IPI don't have executables-            (elaboratedPackage distDirLayout (elaboratedShared buildCtx))-            gpp--    case binfiles of-        [exe] -> putStrLn exe-        _     -> die' verbosity "No or multiple targets given"-  where-    defaultVerbosity = verboseStderr silent-    verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)-    ignoreProject = flagIgnoreProject projectFlags-    prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)--    withProject :: IO (ProjectBaseContext, DistDirLayout)-    withProject = do-        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand-        return (baseCtx, distDirLayout baseCtx)--    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)-    withoutProject config = do-        cwd <- getCurrentDirectory-        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand-        return (baseCtx, distDirLayout baseCtx)--    -- this is copied from-    elaboratedPackage-        :: DistDirLayout-        -> ElaboratedSharedConfig-        -> ElaboratedConfiguredPackage-        -> [FilePath]-    elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of-        ElabPackage pkg ->-            [ bin-            | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg)-                                           (pkgExeDependencies pkg)-            , bin <- bin_file c-            ]-        ElabComponent comp -> bin_file (compSolverName comp)-      where-        dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab)--        bin_file c = case c of-            CD.ComponentExe s   -> [bin_file' s]-            CD.ComponentTest s  -> [bin_file' s]-            CD.ComponentBench s -> [bin_file' s]-            CD.ComponentFLib s  -> [flib_file' s]-            _                -> []--        plat :: Platform-        plat = pkgConfigPlatform elaboratedSharedConfig--        -- here and in PlanOutput,-        -- use binDirectoryFor?-        bin_file' s =-            if elabBuildStyle elab == BuildInplaceOnly-            then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat-            else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat--        flib_file' s =-            if elabBuildStyle elab == BuildInplaceOnly-            then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat-            else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat------------------------------------------------------------------------------------ Target Problem: the very similar to CmdRun----------------------------------------------------------------------------------singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)-singleComponentOrElse action targetsMap =-  case Set.toList . distinctTargetComponents $ targetsMap-  of [(unitId, CExeName component)] -> return (unitId, component)-     [(unitId, CTestName component)] -> return (unitId, component)-     [(unitId, CBenchName component)] -> return (unitId, component)-     [(unitId, CFLibName component)] -> return (unitId, component)-     _   -> action---- | This defines what a 'TargetSelector' means for the @list-bin@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @list-bin@ command we select the exe or flib if there is only one--- and it's buildable. Fail if there are no or multiple buildable exe components.----selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either ListBinTargetProblem [k]-selectPackageTargets targetSelector targets--    -- If there is exactly one buildable executable then we select that-  | [target] <- targetsExesBuildable-  = Right [target]--    -- but fail if there are multiple buildable executables.-  | not (null targetsExesBuildable)-  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')--    -- If there are executables but none are buildable then we report those-  | not (null targetsExes)-  = Left (TargetProblemNoneEnabled targetSelector targetsExes)--    -- If there are no executables but some other targets then we report that-  | not (null targets)-  = Left (noComponentsProblem targetSelector)--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    -- Targets that can be executed-    targetsExecutableLike =-      concatMap (\kind -> filterTargetsKind kind targets)-                [ExeKind, TestKind, BenchKind]-    (targetsExesBuildable,-     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike--    targetsExes             = forgetTargetsDetail targetsExecutableLike----- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @run@ command we just need to check it is a executable-like--- (an executable, a test, or a benchmark), in addition--- to the basic checks on being buildable etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either ListBinTargetProblem  k-selectComponentTarget subtarget@WholeComponent t-  = case availableTargetComponentName t-    of CExeName _ -> component-       CTestName _ -> component-       CBenchName _ -> component-       CFLibName _ -> component-       _ -> Left (componentNotRightKindProblem pkgid cname)-    where pkgid = availableTargetPackageId t-          cname = availableTargetComponentName t-          component = selectComponentTargetBasic subtarget t--selectComponentTarget subtarget t-  = Left (isSubComponentProblem (availableTargetPackageId t)-           (availableTargetComponentName t)-           subtarget)---- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @run@ command.----data ListBinProblem =-     -- | The 'TargetSelector' matches targets but no executables-     TargetProblemNoRightComps      TargetSelector--     -- | A single 'TargetSelector' matches multiple targets-   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]--     -- | Multiple 'TargetSelector's match multiple targets-   | TargetProblemMultipleTargets TargetsMap--     -- | The 'TargetSelector' refers to a component that is not an executable-   | TargetProblemComponentNotRightKind PackageId ComponentName--     -- | Asking to run an individual file or module is not supported-   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget-  deriving (Eq, Show)--type ListBinTargetProblem = TargetProblem ListBinProblem--noComponentsProblem :: TargetSelector -> ListBinTargetProblem-noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps--matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem-matchesMultipleProblem selector targets = CustomTargetProblem $-    TargetProblemMatchesMultiple selector targets--multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem-multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets--componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem-componentNotRightKindProblem pkgid name = CustomTargetProblem $-    TargetProblemComponentNotRightKind pkgid name--isSubComponentProblem-  :: PackageId-  -> ComponentName-  -> SubComponentTarget-  -> TargetProblem ListBinProblem-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $-    TargetProblemIsSubComponent pkgid name subcomponent--reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderListBinTargetProblem--renderListBinTargetProblem :: ListBinTargetProblem -> String-renderListBinTargetProblem (TargetProblemNoTargets targetSelector) =-    case targetSelectorFilter targetSelector of-      Just kind | kind /= ExeKind-        -> "The list-bin command is for finding binaries, but the target '"-           ++ showTargetSelector targetSelector ++ "' refers to "-           ++ renderTargetSelector targetSelector ++ "."--      _ -> renderTargetProblemNoTargets "list-bin" targetSelector-renderListBinTargetProblem problem =-    renderTargetProblem "list-bin" renderListBinProblem problem--renderListBinProblem :: ListBinProblem -> String-renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =-    "The list-bin command is for finding a single binary at once. The target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " which includes "- ++ renderListCommaAnd ( ("the "++) <$>-                         showComponentName <$>-                         availableTargetComponentName <$>-                         foldMap-                           (\kind -> filterTargetsKind kind targets)-                           [ExeKind, TestKind, BenchKind] )- ++ "."--renderListBinProblem (TargetProblemMultipleTargets selectorMap) =-    "The list-bin command is for finding a single binary at once. The targets "- ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"-                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]- ++ " refer to different executables."--renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) =-    "The list-bin command is for finding binaries, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " from the package "- ++ prettyShow pkgid ++ "."-  where-    targetSelector = TargetComponent pkgid cname WholeComponent--renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) =-    "The list-bin command can only find a binary as a whole, "- ++ "not files or modules within them, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ "."-  where-    targetSelector = TargetComponent pkgid cname subtarget--renderListBinProblem (TargetProblemNoRightComps targetSelector) =-    "Cannot list-bin the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any executables or foreign libraries."
− Distribution/Client/CmdRepl.hs 
@@ -1,582 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}---- | cabal-install CLI command: repl----module Distribution.Client.CmdRepl (-    -- * The @repl@ CLI and action-    replCommand,-    replAction,--    -- * Internals exposed for testing-    matchesMultipleProblem,-    selectPackageTargets,-    selectComponentTarget-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Compat.Lens-import qualified Distribution.Types.Lens as L--import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.CmdErrorMessages-         ( renderTargetSelector, showTargetSelector,-           renderTargetProblem,-           targetSelectorRefersToPkgs,-           renderComponentKind, renderListCommaAnd, renderListSemiAnd,-           componentKind, sortGroupOn, Plural(..) )-import Distribution.Client.TargetProblem-         ( TargetProblem(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.ProjectBuilding-         ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )-import Distribution.Client.ProjectConfig-         ( ProjectConfig(..), withProjectOrGlobalConfig-         , projectConfigConfigFile )-import Distribution.Client.ProjectFlags-         ( flagIgnoreProject )-import Distribution.Client.ProjectOrchestration-import Distribution.Client.ProjectPlanning-       ( ElaboratedSharedConfig(..), ElaboratedInstallPlan )-import Distribution.Client.ProjectPlanning.Types-       ( elabOrderExeDependencies )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..) )-import qualified Distribution.Client.Setup as Client-import Distribution.Client.Types-         ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )-import Distribution.Simple.Setup-         ( fromFlagOrDefault, replOptions-         , Flag(..), toFlag, falseArg )-import Distribution.Simple.Command-         ( CommandUI(..), liftOptionL, usageAlternatives, option-         , ShowOrParseArgs, OptionField, reqArg )-import Distribution.Compiler-         ( CompilerFlavor(GHC) )-import Distribution.Simple.Compiler-         ( compilerCompatVersion )-import Distribution.Package-         ( Package(..), packageName, UnitId, installedUnitId )-import Distribution.PackageDescription.PrettyPrint-import Distribution.Parsec-         ( parsecCommaList )-import Distribution.ReadE-         ( ReadE, parsecToReadE )-import qualified Distribution.SPDX.License as SPDX-import Distribution.Solver.Types.SourcePackage-         ( SourcePackage(..) )-import Distribution.Types.BuildInfo-         ( BuildInfo(..), emptyBuildInfo )-import Distribution.Types.ComponentName-         ( componentNameString )-import Distribution.Types.CondTree-         ( CondTree(..), traverseCondTreeC )-import Distribution.Types.Dependency-         ( Dependency(..), mainLibSet )-import Distribution.Types.GenericPackageDescription-         ( emptyGenericPackageDescription )-import Distribution.Types.PackageDescription-         ( PackageDescription(..), emptyPackageDescription )-import Distribution.Types.PackageName.Magic-         ( fakePackageId )-import Distribution.Types.Library-         ( Library(..), emptyLibrary )-import Distribution.Types.Version-         ( mkVersion )-import Distribution.Types.VersionRange-         ( anyVersion )-import Distribution.Utils.Generic-         ( safeHead )-import Distribution.Verbosity-         ( normal, lessVerbose )-import Distribution.Simple.Utils-         ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist )-import Language.Haskell.Extension-         ( Language(..) )-import Distribution.CabalSpecVersion-         ( CabalSpecVersion (..) )--import Data.List-         ( (\\) )-import qualified Data.Map as Map-import qualified Data.Set as Set-import System.Directory-         ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive )-import System.FilePath-         ( (</>) )--type ReplFlags = [String]--data EnvFlags = EnvFlags-  { envPackages :: [Dependency]-  , envIncludeTransitive :: Flag Bool-  }--defaultEnvFlags :: EnvFlags-defaultEnvFlags = EnvFlags-  { envPackages = []-  , envIncludeTransitive = toFlag True-  }--envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]-envOptions _ =-  [ option ['b'] ["build-depends"]-    "Include additional packages in the environment presented to GHCi."-    envPackages (\p flags -> flags { envPackages = p ++ envPackages flags })-    (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String]))-  , option [] ["no-transitive-deps"]-    "Don't automatically include transitive dependencies of requested packages."-    envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })-    falseArg-  ]-  where-    dependenciesReadE :: ReadE [Dependency]-    dependenciesReadE =-      parsecToReadE-        ("couldn't parse dependencies: " ++)-        (parsecCommaList parsec)--replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags))-replCommand = Client.installCommand {-  commandName         = "v2-repl",-  commandSynopsis     = "Open an interactive session for the given component.",-  commandUsage        = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ],-  commandDescription  = Just $ \_ -> wrapText $-        "Open an interactive session for a component within the project. The "-     ++ "available targets are the same as for the 'v2-build' command: "-     ++ "individual components within packages in the project, including "-     ++ "libraries, executables, test-suites or benchmarks. Packages can "-     ++ "also be specified in which case the library component in the "-     ++ "package will be used, or the (first listed) executable in the "-     ++ "package if there is no library.\n\n"--     ++ "Dependencies are built or rebuilt as necessary. Additional "-     ++ "configuration flags can be specified on the command line and these "-     ++ "extend the project configuration from the 'cabal.project', "-     ++ "'cabal.project.local' and other files.",-  commandNotes        = Just $ \pname ->-        "Examples, open an interactive session:\n"-     ++ "  " ++ pname ++ " v2-repl\n"-     ++ "    for the default component in the package in the current directory\n"-     ++ "  " ++ pname ++ " v2-repl pkgname\n"-     ++ "    for the default component in the package named 'pkgname'\n"-     ++ "  " ++ pname ++ " v2-repl ./pkgfoo\n"-     ++ "    for the default component in the package in the ./pkgfoo directory\n"-     ++ "  " ++ pname ++ " v2-repl cname\n"-     ++ "    for the component named 'cname'\n"-     ++ "  " ++ pname ++ " v2-repl pkgname:cname\n"-     ++ "    for the component 'cname' in the package 'pkgname'\n\n"-     ++ "  " ++ pname ++ " v2-repl --build-depends lens\n"-     ++ "    add the latest version of the library 'lens' to the default component "-        ++ "(or no componentif there is no project present)\n"-     ++ "  " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"-     ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "-        ++ "to the default component (or no component if there is no project present)\n",--  commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags),-  commandOptions = nixStyleOptions $ \showOrParseArgs ->-    map (liftOptionL _1) (replOptions showOrParseArgs) ++-    map (liftOptionL _2) (envOptions showOrParseArgs)-  }---- | The @repl@ command is very much like @build@. It brings the install plan--- up to date, selects that part of the plan needed by the given or implicit--- repl target and then executes the plan.------ Compared to @build@ the difference is that only one target is allowed--- (given or implicit) and the target type is repl rather than build. The--- general plan execution infrastructure handles both build and repl targets.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO ()-replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do-    let-      with           = withProject    cliConfig             verbosity targetStrings-      without config = withoutProject (config <> cliConfig) verbosity targetStrings--    (baseCtx, targetSelectors, finalizer, replType) <--      withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without--    when (buildSettingOnlyDeps (buildSettings baseCtx)) $-      die' verbosity $ "The repl command does not support '--only-dependencies'. "-          ++ "You may wish to use 'build --only-dependencies' and then "-          ++ "use 'repl'."--    (originalComponent, baseCtx') <- if null (envPackages envFlags)-      then return (Nothing, baseCtx)-      else-        -- Unfortunately, the best way to do this is to let the normal solver-        -- help us resolve the targets, but that isn't ideal for performance,-        -- especially in the no-project case.-        withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do-          -- targets should be non-empty map, but there's no NonEmptyMap yet.-          targets <- validatedTargets elaboratedPlan targetSelectors--          let-            (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets-            originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId-            oci = OriginalComponentInfo unitId originalDeps-            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId-            baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx--          return (Just oci, baseCtx')--    -- Now, we run the solver again with the added packages. While the graph-    -- won't actually reflect the addition of transitive dependencies,-    -- they're going to be available already and will be offered to the REPL-    -- and that's good enough.-    ---    -- In addition, to avoid a *third* trip through the solver, we are-    -- replicating the second half of 'runProjectPreBuildPhase' by hand-    -- here.-    (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $-      \elaboratedPlan elaboratedShared' -> do-        let ProjectBaseContext{..} = baseCtx'--        -- Recalculate with updated project.-        targets <- validatedTargets elaboratedPlan targetSelectors--        let-          elaboratedPlan' = pruneInstallPlanToTargets-                              TargetActionRepl-                              targets-                              elaboratedPlan-          includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags)--        pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared'-                                          elaboratedPlan'--        let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages-                                pkgsBuildStatus elaboratedPlan'-        debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')--        let-          buildCtx = ProjectBuildContext-            { elaboratedPlanOriginal = elaboratedPlan-            , elaboratedPlanToExecute = elaboratedPlan''-            , elaboratedShared = elaboratedShared'-            , pkgsBuildStatus-            , targetsMap = targets-            }--          ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared'--          -- First version of GHC where GHCi supported the flag we need.-          -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html-          minGhciScriptVersion = mkVersion [7, 6]--          replFlags' = case originalComponent of-            Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci-            Nothing  -> []-          replFlags'' = case replType of-            GlobalRepl scriptPath-              | Just version <- compilerCompatVersion GHC compiler-              , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags'-            _                                   -> replFlags'--        return (buildCtx, replFlags'')--    let buildCtx' = buildCtx-          { elaboratedShared = (elaboratedShared buildCtx)-                { pkgConfigReplOptions = replFlags ++ replFlags'' }-          }-    printPlan verbosity baseCtx' buildCtx'--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx'-    runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes-    finalizer-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    ignoreProject = flagIgnoreProject projectFlags-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)--    validatedTargets elaboratedPlan targetSelectors = do-      -- Interpret the targets on the command line as repl targets-      -- (as opposed to say build or haddock targets).-      targets <- either (reportTargetProblems verbosity) return-          $ resolveTargets-              selectPackageTargets-              selectComponentTarget-              elaboratedPlan-              Nothing-              targetSelectors--      -- Reject multiple targets, or at least targets in different-      -- components. It is ok to have two module/file targets in the-      -- same component, but not two that live in different components.-      when (Set.size (distinctTargetComponents targets) > 1) $-        reportTargetProblems verbosity-          [multipleTargetsProblem targets]--      return targets--data OriginalComponentInfo = OriginalComponentInfo-  { ociUnitId :: UnitId-  , ociOriginalDeps :: [UnitId]-  }-  deriving (Show)---- | Tracks what type of GHCi instance we're creating.-data ReplType = ProjectRepl-              | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi-                                    --   script responsible for changing to the-                                    --   correct directory. Only works on GHC geq-                                    --   7.6, though. 🙁-              deriving (Show, Eq)--withProject :: ProjectConfig -> Verbosity -> [String]-            -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)-withProject cliConfig verbosity targetStrings = do-  baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--  targetSelectors <- either (reportTargetSelectorProblems verbosity) return-                 =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings--  return (baseCtx, targetSelectors, return (), ProjectRepl)--withoutProject :: ProjectConfig -> Verbosity -> [String]-               -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)-withoutProject config verbosity extraArgs = do-  unless (null extraArgs) $-    die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs--  globalTmp <- getTemporaryDirectory-  tempDir <- createTempDirectory globalTmp "cabal-repl."--  -- We need to create a dummy package that lives in our dummy project.-  let-    sourcePackage = SourcePackage-      { srcpkgPackageId     = pkgId-      , srcpkgDescription   = genericPackageDescription-      , srcpkgSource        = LocalUnpackedPackage tempDir-      , srcpkgDescrOverride = Nothing-      }-    genericPackageDescription = emptyGenericPackageDescription-      & L.packageDescription .~ packageDescription-      & L.condLibrary        .~ Just (CondNode library [baseDep] [])-    packageDescription = emptyPackageDescription-      { package = pkgId-      , specVersion = CabalSpecV2_2-      , licenseRaw = Left SPDX.NONE-      }-    library = emptyLibrary { libBuildInfo = buildInfo }-    buildInfo = emptyBuildInfo-      { targetBuildDepends = [baseDep]-      , defaultLanguage = Just Haskell2010-      }-    baseDep = Dependency "base" anyVersion mainLibSet-    pkgId = fakePackageId--  writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription--  let ghciScriptPath = tempDir </> "setcwd.ghci"-  cwd <- getCurrentDirectory-  writeFile ghciScriptPath (":cd " ++ cwd)--  distDirLayout <- establishDummyDistDirLayout verbosity config tempDir-  baseCtx <--    establishDummyProjectBaseContext-      verbosity-      config-      distDirLayout-      [SpecificSourcePackage sourcePackage]-      OtherCommand--  let-    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]-    finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir)--  return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath)--addDepsToProjectTarget :: [Dependency]-                       -> PackageId-                       -> ProjectBaseContext-                       -> ProjectBaseContext-addDepsToProjectTarget deps pkgId ctx =-    (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx-  where-    addDeps :: PackageSpecifier UnresolvedSourcePackage-            -> PackageSpecifier UnresolvedSourcePackage-    addDeps (SpecificSourcePackage pkg)-      | packageId pkg /= pkgId = SpecificSourcePackage pkg-      | SourcePackage{..} <- pkg =-        SpecificSourcePackage $ pkg { srcpkgDescription =-          srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f)-                            %~ (deps ++)-        }-    addDeps spec = spec--generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags-generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags-  where-    exeDeps :: [UnitId]-    exeDeps =-      foldMap-        (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)-        (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])--    deps, deps', trans, trans' :: [UnitId]-    flags :: ReplFlags-    deps   = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId-    deps'  = deps \\ ociOriginalDeps-    trans  = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'-    trans' = trans \\ ociOriginalDeps-    flags  = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps)-      $ if includeTransitive then trans' else deps'---- | This defines what a 'TargetSelector' means for the @repl@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For repl we select:------ * the library if there is only one and it's buildable; or------ * the exe if there is only one and it's buildable; or------ * any other buildable component.------ Fail if there are no buildable lib\/exe components, or if there are--- multiple libs or exes.----selectPackageTargets  :: TargetSelector-                      -> [AvailableTarget k] -> Either ReplTargetProblem [k]-selectPackageTargets targetSelector targets--    -- If there is exactly one buildable library then we select that-  | [target] <- targetsLibsBuildable-  = Right [target]--    -- but fail if there are multiple buildable libraries.-  | not (null targetsLibsBuildable)-  = Left (matchesMultipleProblem targetSelector targetsLibsBuildable')--    -- If there is exactly one buildable executable then we select that-  | [target] <- targetsExesBuildable-  = Right [target]--    -- but fail if there are multiple buildable executables.-  | not (null targetsExesBuildable)-  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')--    -- If there is exactly one other target then we select that-  | [target] <- targetsBuildable-  = Right [target]--    -- but fail if there are multiple such targets-  | not (null targetsBuildable)-  = Left (matchesMultipleProblem targetSelector targetsBuildable')--    -- If there are targets but none are buildable then we report those-  | not (null targets)-  = Left (TargetProblemNoneEnabled targetSelector targets')--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    targets'                = forgetTargetsDetail targets-    (targetsLibsBuildable,-     targetsLibsBuildable') = selectBuildableTargets'-                            . filterTargetsKind LibKind-                            $ targets-    (targetsExesBuildable,-     targetsExesBuildable') = selectBuildableTargets'-                            . filterTargetsKind ExeKind-                            $ targets-    (targetsBuildable,-     targetsBuildable')     = selectBuildableTargetsWith'-                                (isRequested targetSelector) targets--    -- When there's a target filter like "pkg:tests" then we do select tests,-    -- but if it's just a target like "pkg" then we don't build tests unless-    -- they are requested by default (i.e. by using --enable-tests)-    isRequested (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False-    isRequested (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False-    isRequested _ _ = True----- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @repl@ command we just need the basic checks on being buildable etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either ReplTargetProblem k-selectComponentTarget = selectComponentTargetBasic---data ReplProblem-  = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]--    -- | Multiple 'TargetSelector's match multiple targets-  | TargetProblemMultipleTargets TargetsMap-  deriving (Eq, Show)---- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.----type ReplTargetProblem = TargetProblem ReplProblem--matchesMultipleProblem-  :: TargetSelector-  -> [AvailableTarget ()]-  -> ReplTargetProblem-matchesMultipleProblem targetSelector targetsExesBuildable =-  CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable--multipleTargetsProblem-  :: TargetsMap-  -> ReplTargetProblem-multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets--reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderReplTargetProblem--renderReplTargetProblem :: TargetProblem ReplProblem -> String-renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem--renderReplProblem :: ReplProblem -> String-renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) =-    "Cannot open a repl for multiple components at once. The target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " which "- ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ")- ++ renderListSemiAnd-      [ "the " ++ renderComponentKind Plural ckind ++ " " ++-        renderListCommaAnd-          [ maybe (prettyShow pkgname) prettyShow (componentNameString cname)-          | t <- ts-          , let cname   = availableTargetComponentName t-                pkgname = packageName (availableTargetPackageId t)-          ]-      | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets-      ]- ++ ".\n\n" ++ explanationSingleComponentLimitation-  where-    availableTargetComponentKind = componentKind-                                 . availableTargetComponentName--renderReplProblem (TargetProblemMultipleTargets selectorMap) =-    "Cannot open a repl for multiple components at once. The targets "- ++ renderListCommaAnd-      [ "'" ++ showTargetSelector ts ++ "'"-      | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]- ++ " refer to different components."- ++ ".\n\n" ++ explanationSingleComponentLimitation--explanationSingleComponentLimitation :: String-explanationSingleComponentLimitation =-    "The reason for this limitation is that current versions of ghci do not "- ++ "support loading multiple components as source. Load just one component "- ++ "and when you make changes to a dependent component then quit and reload."
− Distribution/Client/CmdRun.hs 
@@ -1,632 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---- | cabal-install CLI command: run----module Distribution.Client.CmdRun (-    -- * The @run@ CLI and action-    runCommand,-    runAction,-    handleShebang, validScript,--    -- * Internals exposed for testing-    matchesMultipleProblem,-    noExesProblem,-    selectPackageTargets,-    selectComponentTarget-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (toList)--import Distribution.Client.ProjectOrchestration-import Distribution.Client.CmdErrorMessages-         ( renderTargetSelector, showTargetSelector,-           renderTargetProblem,-           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,-           targetSelectorFilter, renderListCommaAnd )-import Distribution.Client.TargetProblem-         ( TargetProblem (..) )--import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-         ( GlobalFlags(..), ConfigFlags(..) )-import Distribution.Client.GlobalFlags-         ( defaultGlobalFlags )-import Distribution.Simple.Flag-         ( fromFlagOrDefault )-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )-import Distribution.Types.ComponentName-         ( showComponentName )-import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest)-import Distribution.Verbosity-         ( normal )-import Distribution.Simple.Utils-         ( wrapText, warn, die', ordNub, info-         , createTempDirectory, handleDoesNotExist )-import Distribution.Client.ProjectConfig-         ( ProjectConfig(..), ProjectConfigShared(..)-         , withProjectOrGlobalConfig )-import Distribution.Client.ProjectFlags-         ( flagIgnoreProject )-import Distribution.Client.ProjectPlanning-         ( ElaboratedConfiguredPackage(..)-         , ElaboratedInstallPlan, binDirectoryFor )-import Distribution.Client.ProjectPlanning.Types-         ( dataDirsEnvironmentForPlan )-import Distribution.Client.TargetSelector-         ( TargetSelectorProblem(..), TargetString(..) )-import Distribution.Client.InstallPlan-         ( toList, foldPlanPackage )-import Distribution.Types.UnqualComponentName-         ( UnqualComponentName, unUnqualComponentName )-import Distribution.Simple.Program.Run-         ( runProgramInvocation, ProgramInvocation(..),-           emptyProgramInvocation )-import Distribution.Types.UnitId-         ( UnitId )--import Distribution.Client.Types-         ( PackageLocation(..), PackageSpecifier(..) )-import Distribution.FieldGrammar-         ( takeFields, parseFieldGrammar )-import Distribution.PackageDescription.FieldGrammar-         ( executableFieldGrammar )-import Distribution.PackageDescription.PrettyPrint-         ( writeGenericPackageDescription )-import Distribution.Parsec-         ( Position(..) )-import Distribution.Fields-         ( ParseResult, parseString, parseFatalFailure, readFields )-import qualified Distribution.SPDX.License as SPDX-import Distribution.Solver.Types.SourcePackage as SP-         ( SourcePackage(..) )-import Distribution.Types.BuildInfo-         ( BuildInfo(..) )-import Distribution.Types.CondTree-         ( CondTree(..) )-import Distribution.Types.Executable-         ( Executable(..) )-import Distribution.Types.GenericPackageDescription as GPD-         ( GenericPackageDescription(..), emptyGenericPackageDescription )-import Distribution.Types.PackageDescription-         ( PackageDescription(..), emptyPackageDescription )-import Distribution.Types.PackageName.Magic-         ( fakePackageId )-import Language.Haskell.Extension-         ( Language(..) )--import qualified Data.ByteString.Char8 as BS-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Text.Parsec as P-import System.Directory-         ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist )-import System.FilePath-         ( (</>), isValid, isPathSeparator, takeExtension )---runCommand :: CommandUI (NixStyleFlags ())-runCommand = CommandUI-  { commandName         = "v2-run"-  , commandSynopsis     = "Run an executable."-  , commandUsage        = usageAlternatives "v2-run"-                          [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ]-  , commandDescription  = Just $ \pname -> wrapText $-         "Runs the specified executable-like component (an executable, a test, "-      ++ "or a benchmark), first ensuring it is up to date.\n\n"--      ++ "Any executable-like component in any package in the project can be "-      ++ "specified. A package can be specified if contains just one "-      ++ "executable-like. The default is to use the package in the current "-      ++ "directory if it contains just one executable-like.\n\n"--      ++ "Extra arguments can be passed to the program, but use '--' to "-      ++ "separate arguments for the program from arguments for " ++ pname-      ++ ". The executable is run in an environment where it can find its "-      ++ "data files inplace in the build tree.\n\n"--      ++ "Dependencies are built or rebuilt as necessary. Additional "-      ++ "configuration flags can be specified on the command line and these "-      ++ "extend the project configuration from the 'cabal.project', "-      ++ "'cabal.project.local' and other files."-  , commandNotes        = Just $ \pname ->-         "Examples:\n"-      ++ "  " ++ pname ++ " v2-run\n"-      ++ "    Run the executable-like in the package in the current directory\n"-      ++ "  " ++ pname ++ " v2-run foo-tool\n"-      ++ "    Run the named executable-like (in any package in the project)\n"-      ++ "  " ++ pname ++ " v2-run pkgfoo:foo-tool\n"-      ++ "    Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"-      ++ "  " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"-      ++ "    Build with '-O2' and run the program, passing it extra arguments.\n"--  , commandDefaultFlags = defaultNixStyleFlags ()-  , commandOptions      = nixStyleOptions (const [])-  }---- | The @run@ command runs a specified executable-like component, building it--- first if necessary. The component can be either an executable, a test,--- or a benchmark. This is particularly useful for passing arguments to--- exes/tests/benchs by simply appending them after a @--@.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-runAction flags@NixStyleFlags {..} targetStrings globalFlags = do-    globalTmp <- getTemporaryDirectory-    tmpDir <- createTempDirectory globalTmp "cabal-repl."--    let-      with =-        establishProjectBaseContext verbosity cliConfig OtherCommand-      without config = do-        distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir-        establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand--    baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without--    let-      scriptOrError script err = do-        exists <- doesFileExist script-        let pol | takeExtension script == ".lhs" = LiterateHaskell-                | otherwise                      = PlainHaskell-        if exists-          then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir-          else reportTargetSelectorProblems verbosity err--    (baseCtx', targetSelectors) <--      readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings)-        >>= \case-          Left err@(TargetSelectorNoTargetsInProject:_)-            | (script:_) <- targetStrings -> scriptOrError script err-          Left err@(TargetSelectorNoSuch t _:_)-            | TargetString1 script <- t   -> scriptOrError script err-          Left err@(TargetSelectorExpected t _ _:_)-            | TargetString1 script <- t   -> scriptOrError script err-          Left err   -> reportTargetSelectorProblems verbosity err-          Right sels -> return (baseCtx, sels)--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do--            when (buildSettingOnlyDeps (buildSettings baseCtx')) $-              die' verbosity $-                  "The run command does not support '--only-dependencies'. "-               ++ "You may wish to use 'build --only-dependencies' and then "-               ++ "use 'run'."--            -- Interpret the targets on the command line as build targets-            -- (as opposed to say repl or haddock targets).-            targets <- either (reportTargetProblems verbosity) return-                     $ resolveTargets-                         selectPackageTargets-                         selectComponentTarget-                         elaboratedPlan-                         Nothing-                         targetSelectors--            -- Reject multiple targets, or at least targets in different-            -- components. It is ok to have two module/file targets in the-            -- same component, but not two that live in different components.-            ---            -- Note that we discard the target and return the whole 'TargetsMap',-            -- so this check will be repeated (and must succeed) after-            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.-            _ <- singleExeOrElse-                   (reportTargetProblems-                      verbosity-                      [multipleTargetsProblem targets])-                   targets--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionBuild-                                    targets-                                    elaboratedPlan-            return (elaboratedPlan', targets)--    (selectedUnitId, selectedComponent) <--      -- Slight duplication with 'runProjectPreBuildPhase'.-      singleExeOrElse-        (die' verbosity $ "No or multiple targets given, but the run "-                       ++ "phase has been reached. This is a bug.")-        $ targetsMap buildCtx--    printPlan verbosity baseCtx' buildCtx--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx-    runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes---    let elaboratedPlan = elaboratedPlanToExecute buildCtx-        matchingElaboratedConfiguredPackages =-          matchingPackagesByUnitId-            selectedUnitId-            elaboratedPlan--    let exeName = unUnqualComponentName selectedComponent--    -- In the common case, we expect @matchingElaboratedConfiguredPackages@-    -- to consist of a single element that provides a single way of building-    -- an appropriately-named executable. In that case we take that-    -- package and continue.-    ---    -- However, multiple packages/components could provide that-    -- executable, or it's possible we don't find the executable anywhere-    -- in the build plan. I suppose in principle it's also possible that-    -- a single package provides an executable in two different ways,-    -- though that's probably a bug if. Anyway it's a good lint to report-    -- an error in all of these cases, even if some seem like they-    -- shouldn't happen.-    pkg <- case matchingElaboratedConfiguredPackages of-      [] -> die' verbosity $ "Unknown executable "-                          ++ exeName-                          ++ " in package "-                          ++ prettyShow selectedUnitId-      [elabPkg] -> do-        info verbosity $ "Selecting "-                       ++ prettyShow selectedUnitId-                       ++ " to supply " ++ exeName-        return elabPkg-      elabPkgs -> die' verbosity-        $ "Multiple matching executables found matching "-        ++ exeName-        ++ ":\n"-        ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)-    let exePath = binDirectoryFor (distDirLayout baseCtx)-                                  (elaboratedShared buildCtx)-                                  pkg-                                  exeName-               </> exeName-    let args = drop 1 targetStrings-    runProgramInvocation-      verbosity-      emptyProgramInvocation {-        progInvokePath  = exePath,-        progInvokeArgs  = args,-        progInvokeEnv   = dataDirsEnvironmentForPlan-                            (distDirLayout baseCtx)-                            elaboratedPlan-      }--    handleDoesNotExist () (removeDirectoryRecursive tmpDir)-  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    ignoreProject = flagIgnoreProject projectFlags-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)---- | Used by the main CLI parser as heuristic to decide whether @cabal@ was--- invoked as a script interpreter, i.e. via------ > #! /usr/bin/env cabal------ or------ > #! /usr/bin/cabal------ As the first argument passed to `cabal` will be a filepath to the--- script to be interpreted.------ See also 'handleShebang'-validScript :: String -> IO Bool-validScript script-  | isValid script && any isPathSeparator script = doesFileExist script-  | otherwise = return False---- | Handle @cabal@ invoked as script interpreter, see also 'validScript'------ First argument is the 'FilePath' to the script to be executed; second--- argument is a list of arguments to be passed to the script.-handleShebang :: FilePath -> [String] -> IO ()-handleShebang script args =-  runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags--parseScriptBlock :: BS.ByteString -> ParseResult Executable-parseScriptBlock str =-    case readFields str of-        Right fs -> do-            let (fields, _) = takeFields fs-            parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")-        Left perr -> parseFatalFailure pos (show perr) where-            ppos = P.errorPos perr-            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)--readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable-readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"--readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString)-readScriptBlockFromScript verbosity pol str = do-    str' <- case extractScriptBlock pol str of-              Left e -> die' verbosity $ "Failed extracting script block: " ++ e-              Right x -> return x-    when (BS.all isSpace str') $ warn verbosity "Empty script block"-    (\x -> (x, noShebang)) <$> readScriptBlock verbosity str'-  where-    noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str---- | Extract the first encountered script metadata block started end--- terminated by the tokens------ * @{- cabal:@------ * @-}@------ appearing alone on lines (while tolerating trailing whitespace).--- These tokens are not part of the 'Right' result.------ In case of missing or unterminated blocks a 'Left'-error is--- returned.-extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString-extractScriptBlock _pol str = goPre (BS.lines str)-  where-    isStartMarker = (== startMarker) . stripTrailSpace-    isEndMarker   = (== endMarker) . stripTrailSpace--    stripTrailSpace = fst . BS.spanEnd isSpace--    -- before start marker-    goPre ls = case dropWhile (not . isStartMarker) ls of-                 [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"-                 (_:ls') -> goBody [] ls'--    goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"-    goBody acc (l:ls)-      | isEndMarker l = Right $! BS.unlines $ reverse acc-      | otherwise     = goBody (l:acc) ls--    startMarker, endMarker :: BS.ByteString-    startMarker = fromString "{- cabal:"-    endMarker   = fromString "-}"--data PlainOrLiterate-    = PlainHaskell-    | LiterateHaskell--handleScriptCase-  :: Verbosity-  -> PlainOrLiterate-  -> ProjectBaseContext-  -> FilePath-  -> BS.ByteString-  -> IO (ProjectBaseContext, [TargetSelector])-handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do-  (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents--  -- We need to create a dummy package that lives in our dummy project.-  let-    mainName = case pol of-      PlainHaskell    -> "Main.hs"-      LiterateHaskell -> "Main.lhs"--    sourcePackage = SourcePackage-      { srcpkgPackageId      = pkgId-      , srcpkgDescription    = genericPackageDescription-      , srcpkgSource         = LocalUnpackedPackage tmpDir-      , srcpkgDescrOverride  = Nothing-      }-    genericPackageDescription  = emptyGenericPackageDescription-      { GPD.packageDescription = packageDescription-      , condExecutables        = [("script", CondNode executable' targetBuildDepends [])]-      }-    executable' = executable-      { modulePath = mainName-      , buildInfo = binfo-        { defaultLanguage =-          case defaultLanguage of-            just@(Just _) -> just-            Nothing       -> Just Haskell2010-        }-      }-    binfo@BuildInfo{..} = buildInfo executable-    packageDescription = emptyPackageDescription-      { package = pkgId-      , specVersion = CabalSpecV2_2-      , licenseRaw = Left SPDX.NONE-      }-    pkgId = fakePackageId--  writeGenericPackageDescription (tmpDir </> "fake-package.cabal") genericPackageDescription-  BS.writeFile (tmpDir </> mainName) contents'--  let-    baseCtx' = baseCtx-      { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] }-    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]--  return (baseCtx', targetSelectors)--singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)-singleExeOrElse action targetsMap =-  case Set.toList . distinctTargetComponents $ targetsMap-  of [(unitId, CExeName component)] -> return (unitId, component)-     [(unitId, CTestName component)] -> return (unitId, component)-     [(unitId, CBenchName component)] -> return (unitId, component)-     _   -> action---- | Filter the 'ElaboratedInstallPlan' keeping only the--- 'ElaboratedConfiguredPackage's that match the specified--- 'UnitId'.-matchingPackagesByUnitId :: UnitId-                         -> ElaboratedInstallPlan-                         -> [ElaboratedConfiguredPackage]-matchingPackagesByUnitId uid =-          catMaybes-          . fmap (foldPlanPackage-                    (const Nothing)-                    (\x -> if elabUnitId x == uid-                           then Just x-                           else Nothing))-          . toList---- | This defines what a 'TargetSelector' means for the @run@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @run@ command we select the exe if there is only one and it's--- buildable. Fail if there are no or multiple buildable exe components.----selectPackageTargets :: TargetSelector-                     -> [AvailableTarget k] -> Either RunTargetProblem [k]-selectPackageTargets targetSelector targets--    -- If there is exactly one buildable executable then we select that-  | [target] <- targetsExesBuildable-  = Right [target]--    -- but fail if there are multiple buildable executables.-  | not (null targetsExesBuildable)-  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')--    -- If there are executables but none are buildable then we report those-  | not (null targetsExes)-  = Left (TargetProblemNoneEnabled targetSelector targetsExes)--    -- If there are no executables but some other targets then we report that-  | not (null targets)-  = Left (noExesProblem targetSelector)--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    -- Targets that can be executed-    targetsExecutableLike =-      concatMap (\kind -> filterTargetsKind kind targets)-                [ExeKind, TestKind, BenchKind]-    (targetsExesBuildable,-     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike--    targetsExes             = forgetTargetsDetail targetsExecutableLike----- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @run@ command we just need to check it is a executable-like--- (an executable, a test, or a benchmark), in addition--- to the basic checks on being buildable etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either RunTargetProblem  k-selectComponentTarget subtarget@WholeComponent t-  = case availableTargetComponentName t-    of CExeName _ -> component-       CTestName _ -> component-       CBenchName _ -> component-       _ -> Left (componentNotExeProblem pkgid cname)-    where pkgid = availableTargetPackageId t-          cname = availableTargetComponentName t-          component = selectComponentTargetBasic subtarget t--selectComponentTarget subtarget t-  = Left (isSubComponentProblem (availableTargetPackageId t)-           (availableTargetComponentName t)-           subtarget)---- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @run@ command.----data RunProblem =-     -- | The 'TargetSelector' matches targets but no executables-     TargetProblemNoExes      TargetSelector--     -- | A single 'TargetSelector' matches multiple targets-   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]--     -- | Multiple 'TargetSelector's match multiple targets-   | TargetProblemMultipleTargets TargetsMap--     -- | The 'TargetSelector' refers to a component that is not an executable-   | TargetProblemComponentNotExe PackageId ComponentName--     -- | Asking to run an individual file or module is not supported-   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget-  deriving (Eq, Show)--type RunTargetProblem = TargetProblem RunProblem--noExesProblem :: TargetSelector -> RunTargetProblem-noExesProblem = CustomTargetProblem . TargetProblemNoExes--matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem-matchesMultipleProblem selector targets = CustomTargetProblem $-    TargetProblemMatchesMultiple selector targets--multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem-multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets--componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem-componentNotExeProblem pkgid name = CustomTargetProblem $-    TargetProblemComponentNotExe pkgid name--isSubComponentProblem-  :: PackageId-  -> ComponentName-  -> SubComponentTarget-  -> TargetProblem RunProblem-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $-    TargetProblemIsSubComponent pkgid name subcomponent--reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a-reportTargetProblems verbosity =-    die' verbosity . unlines . map renderRunTargetProblem--renderRunTargetProblem :: RunTargetProblem -> String-renderRunTargetProblem (TargetProblemNoTargets targetSelector) =-    case targetSelectorFilter targetSelector of-      Just kind | kind /= ExeKind-        -> "The run command is for running executables, but the target '"-           ++ showTargetSelector targetSelector ++ "' refers to "-           ++ renderTargetSelector targetSelector ++ "."--      _ -> renderTargetProblemNoTargets "run" targetSelector-renderRunTargetProblem problem =-    renderTargetProblem "run" renderRunProblem problem--renderRunProblem :: RunProblem -> String-renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) =-    "The run command is for running a single executable at once. The target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " which includes "- ++ renderListCommaAnd ( ("the "++) <$>-                         showComponentName <$>-                         availableTargetComponentName <$>-                         foldMap-                           (\kind -> filterTargetsKind kind targets)-                           [ExeKind, TestKind, BenchKind] )- ++ "."--renderRunProblem (TargetProblemMultipleTargets selectorMap) =-    "The run command is for running a single executable at once. The targets "- ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"-                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]- ++ " refer to different executables."--renderRunProblem (TargetProblemComponentNotExe pkgid cname) =-    "The run command is for running executables, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " from the package "- ++ prettyShow pkgid ++ "."-  where-    targetSelector = TargetComponent pkgid cname WholeComponent--renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) =-    "The run command can only run an executable as a whole, "- ++ "not files or modules within them, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ "."-  where-    targetSelector = TargetComponent pkgid cname subtarget--renderRunProblem (TargetProblemNoExes targetSelector) =-    "Cannot run the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any executables."
− Distribution/Client/CmdSdist.hs 
@@ -1,302 +0,0 @@-{-# LANGUAGE MultiWayIf        #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}-module Distribution.Client.CmdSdist-    ( sdistCommand, sdistAction, packageToSdist-    , OutputFormat(..)) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.CmdErrorMessages-    ( Plural(..), renderComponentKind )-import Distribution.Client.ProjectOrchestration-    ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)-import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), defaultNixStyleFlags )-import Distribution.Client.TargetSelector-    ( TargetSelector(..), ComponentKind-    , readTargetSelectors, reportTargetSelectorProblems )-import Distribution.Client.Setup-    ( GlobalFlags(..) )-import Distribution.Solver.Types.SourcePackage-    ( SourcePackage(..) )-import Distribution.Client.Types-    ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )-import Distribution.Client.DistDirLayout-    ( DistDirLayout(..), ProjectRoot (..) )-import Distribution.Client.ProjectConfig-    ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )-import Distribution.Client.ProjectFlags-     ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions )--import Distribution.Compat.Lens-    ( _1, _2 )-import Distribution.Package-    ( Package(packageId) )-import Distribution.PackageDescription.Configuration-    ( flattenPackageDescription )-import Distribution.ReadE-    ( succeedReadE )-import Distribution.Simple.Command-    ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs )-import Distribution.Simple.PreProcess-    ( knownSuffixHandlers )-import Distribution.Simple.Setup-    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe-    , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref-    )-import Distribution.Simple.SrcDist-    ( listPackageSources )-import Distribution.Client.SrcDist-    ( packageDirToSdist )-import Distribution.Simple.Utils-    ( die', notice, withOutputMarker, wrapText )-import Distribution.Types.ComponentName-    ( ComponentName, showComponentName )-import Distribution.Types.PackageName-    ( PackageName, unPackageName )-import Distribution.Verbosity-    ( normal )--import qualified Data.ByteString.Lazy.Char8 as BSL-import System.Directory-    ( getCurrentDirectory-    , createDirectoryIfMissing, makeAbsolute-    )-import System.FilePath-    ( (</>), (<.>), makeRelative, normalise )------------------------------------------------------------------------------------ Command----------------------------------------------------------------------------------sdistCommand :: CommandUI (ProjectFlags, SdistFlags)-sdistCommand = CommandUI-    { commandName = "v2-sdist"-    , commandSynopsis = "Generate a source distribution file (.tar.gz)."-    , commandUsage = \pname ->-        "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n"-    , commandDescription  = Just $ \_ -> wrapText-        "Generates tarballs of project packages suitable for upload to Hackage."-    , commandNotes = Nothing-    , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)-    , commandOptions = \showOrParseArgs ->-        map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++-        map (liftOptionL _2) (sdistOptions showOrParseArgs)-    }------------------------------------------------------------------------------------ Flags----------------------------------------------------------------------------------data SdistFlags = SdistFlags-    { sdistVerbosity     :: Flag Verbosity-    , sdistDistDir       :: Flag FilePath-    , sdistListSources   :: Flag Bool-    , sdistNulSeparated  :: Flag Bool-    , sdistOutputPath    :: Flag FilePath-    }--defaultSdistFlags :: SdistFlags-defaultSdistFlags = SdistFlags-    { sdistVerbosity     = toFlag normal-    , sdistDistDir       = mempty-    , sdistListSources   = toFlag False-    , sdistNulSeparated  = toFlag False-    , sdistOutputPath    = mempty-    }--sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]-sdistOptions showOrParseArgs =-    [ optionVerbosity-        sdistVerbosity (\v flags -> flags { sdistVerbosity = v })-    , optionDistPref-        sdistDistDir (\dd flags -> flags { sdistDistDir = dd })-        showOrParseArgs-    , option ['l'] ["list-only"]-        "Just list the sources, do not make a tarball"-        sdistListSources (\v flags -> flags { sdistListSources = v })-        trueArg-    , option [] ["null-sep"]-        "Separate the source files with NUL bytes rather than newlines."-        sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })-        trueArg-    , option ['o'] ["output-directory", "outputdir"]-        "Choose the output directory of this command. '-' sends all output to stdout"-        sdistOutputPath (\o flags -> flags { sdistOutputPath = o })-        (reqArg "PATH" (succeedReadE Flag) flagToList)-    ]------------------------------------------------------------------------------------ Action----------------------------------------------------------------------------------sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()-sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do-    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject--    let localPkgs = localPackages baseCtx--    targetSelectors <- either (reportTargetSelectorProblems verbosity) return-        =<< readTargetSelectors localPkgs Nothing targetStrings--    -- elaborate path, create target directory-    mOutputPath' <- case mOutputPath of-        Just "-"  -> return (Just "-")-        Just path -> do-            abspath <- makeAbsolute path-            createDirectoryIfMissing True abspath-            return (Just abspath)-        Nothing   -> do-            createDirectoryIfMissing True (distSdistDirectory distDirLayout)-            return Nothing--    let format :: OutputFormat-        format =-            if | listSources, nulSeparated -> SourceList '\0'-               | listSources               -> SourceList '\n'-               | otherwise                 -> TarGzArchive--        ext = case format of-                SourceList _  -> "list"-                TarGzArchive  -> "tar.gz"--        outputPath pkg = case mOutputPath' of-            Just path-                | path == "-" -> "-"-                | otherwise   -> path </> prettyShow (packageId pkg) <.> ext-            Nothing-                | listSources -> "-"-                | otherwise   -> distSdistFile distDirLayout (packageId pkg)---    case reifyTargetSelectors localPkgs targetSelectors of-        Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs-        Right pkgs-            | length pkgs > 1, not listSources, Just "-" <- mOutputPath' ->-                die' verbosity "Can't write multiple tarballs to standard output!"-            | otherwise ->-                traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs-  where-    verbosity      = fromFlagOrDefault normal sdistVerbosity-    listSources    = fromFlagOrDefault False sdistListSources-    nulSeparated   = fromFlagOrDefault False sdistNulSeparated-    mOutputPath    = flagToMaybe sdistOutputPath-    ignoreProject  = flagIgnoreProject--    prjConfig :: ProjectConfig-    prjConfig = commandLineFlagsToProjectConfig-        globalFlags-        (defaultNixStyleFlags ())-          { configFlags = (configFlags $ defaultNixStyleFlags ())-            { configVerbosity = sdistVerbosity-            , configDistPref = sdistDistDir-            }-          }-        mempty--    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)--    withProject :: IO (ProjectBaseContext, DistDirLayout)-    withProject = do-        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand-        return (baseCtx, distDirLayout baseCtx)--    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)-    withoutProject config = do-        cwd <- getCurrentDirectory-        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand-        return (baseCtx, distDirLayout baseCtx)--data OutputFormat = SourceList Char-                  | TarGzArchive-                  deriving (Show, Eq)--packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()-packageToSdist verbosity projectRootDir format outputFile pkg = do-    let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))-    dir0 <- case srcpkgSource pkg of-             LocalUnpackedPackage path             -> pure (Right path)-             RemoteSourceRepoPackage _ (Just tgz)  -> pure (Left tgz)-             RemoteSourceRepoPackage {}            -> death-             LocalTarballPackage tgz               -> pure (Left tgz)-             RemoteTarballPackage _ (Just tgz)     -> pure (Left tgz)-             RemoteTarballPackage {}               -> death-             RepoTarballPackage {}                 -> death--    let -- Write String to stdout or file, using the default TextEncoding.-        write str-          | outputFile == "-" = putStr (withOutputMarker verbosity str)-          | otherwise = do-            writeFile outputFile str-            notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"-        -- Write raw ByteString to stdout or file as it is, without encoding.-        writeLBS lbs-          | outputFile == "-" = BSL.putStr lbs-          | otherwise = do-            BSL.writeFile outputFile lbs-            notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"--    case dir0 of-      Left tgz -> do-        case format of-          TarGzArchive -> do-            writeLBS =<< BSL.readFile tgz-          _ -> die' verbosity ("cannot convert tarball package to " ++ show format)--      Right dir -> case format of-        SourceList nulSep -> do-          files' <- listPackageSources verbosity dir (flattenPackageDescription $ srcpkgDescription pkg) knownSuffixHandlers-          let files = nub $ sort $ map normalise files'-          let prefix = makeRelative projectRootDir dir-          write $ concat [prefix </> i ++ [nulSep] | i <- files]--        TarGzArchive -> do-          packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS------reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]-reifyTargetSelectors pkgs sels =-    case partitionEithers (foldMap go sels) of-        ([], sels') -> Right sels'-        (errs, _)   -> Left errs-    where-        flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg-        flatten _ = error "The impossible happened: how do we not know about a local package?"-        pkgs' = fmap flatten pkgs--        getPkg pid = case find ((== pid) . packageId) pkgs' of-            Just pkg -> Right pkg-            Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages."--        go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]-        go (TargetPackage _ pids Nothing) = fmap getPkg pids-        go (TargetAllPackages Nothing) = Right <$> pkgs'--        go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)]-        go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)]--        go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)]-        go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)]--        go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)]--data TargetProblem = AllComponentsOnly ComponentKind-                   | NonlocalPackageNotAllowed PackageName-                   | ComponentsNotAllowed ComponentName--renderTargetProblem :: TargetProblem -> String-renderTargetProblem (AllComponentsOnly kind) =-    "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package "-    ++ "for distribution. Only entire packages may be packaged for distribution."-renderTargetProblem (ComponentsNotAllowed cname) =-    "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. "-    ++ "Only entire packages may be packaged for distribution."-renderTargetProblem (NonlocalPackageNotAllowed pname) =-    "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not "-    ++ "local to this project."
− Distribution/Client/CmdTest.hs 
@@ -1,283 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | cabal-install CLI command: test----module Distribution.Client.CmdTest (-    -- * The @test@ CLI and action-    testCommand,-    testAction,--    -- * Internals exposed for testing-    isSubComponentProblem,-    notTestProblem,-    noTestsProblem,-    selectPackageTargets,-    selectComponentTarget-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.ProjectOrchestration-import Distribution.Client.CmdErrorMessages-         ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural,-           renderTargetProblem,-           renderTargetProblemNoTargets, targetSelectorPluralPkgs )-import Distribution.Client.TargetProblem-         ( TargetProblem (..) )-import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Setup-         ( GlobalFlags(..), ConfigFlags(..) )-import Distribution.Simple.Setup-         ( TestFlags(..), fromFlagOrDefault )-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )-import Distribution.Simple.Flag-         ( Flag(..) )-import Distribution.Verbosity-         ( normal )-import Distribution.Simple.Utils-         ( notice, wrapText, die' )--import qualified System.Exit (exitSuccess)---testCommand :: CommandUI (NixStyleFlags ())-testCommand = CommandUI-  { commandName         = "v2-test"-  , commandSynopsis     = "Run test-suites"-  , commandUsage        = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ]-  , commandDescription  = Just $ \_ -> wrapText $-        "Runs the specified test-suites, first ensuring they are up to "-     ++ "date.\n\n"--     ++ "Any test-suite in any package in the project can be specified. "-     ++ "A package can be specified in which case all the test-suites in the "-     ++ "package are run. The default is to run all the test-suites in the "-     ++ "package in the current directory.\n\n"--     ++ "Dependencies are built or rebuilt as necessary. Additional "-     ++ "configuration flags can be specified on the command line and these "-     ++ "extend the project configuration from the 'cabal.project', "-     ++ "'cabal.project.local' and other files.\n\n"--     ++ "To pass command-line arguments to a test suite, see the "-     ++ "v2-run command."-  , commandNotes        = Just $ \pname ->-        "Examples:\n"-     ++ "  " ++ pname ++ " v2-test\n"-     ++ "    Run all the test-suites in the package in the current directory\n"-     ++ "  " ++ pname ++ " v2-test pkgname\n"-     ++ "    Run all the test-suites in the package named pkgname\n"-     ++ "  " ++ pname ++ " v2-test cname\n"-     ++ "    Run the test-suite named cname\n"-     ++ "  " ++ pname ++ " v2-test cname --enable-coverage\n"-     ++ "    Run the test-suite built with code coverage (including local libs used)\n"--  , commandDefaultFlags = defaultNixStyleFlags ()-  , commandOptions      = nixStyleOptions (const [])-  }------ | The @test@ command is very much like @build@. It brings the install plan--- up to date, selects that part of the plan needed by the given or implicit--- test target(s) and then executes the plan.------ Compared to @build@ the difference is that there's also test targets--- which are ephemeral.------ For more details on how this works, see the module--- "Distribution.Client.ProjectOrchestration"----testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-testAction flags@NixStyleFlags {..} targetStrings globalFlags = do--    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand--    targetSelectors <- either (reportTargetSelectorProblems verbosity) return-                   =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings--    buildCtx <--      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do--            when (buildSettingOnlyDeps (buildSettings baseCtx)) $-              die' verbosity $-                  "The test command does not support '--only-dependencies'. "-               ++ "You may wish to use 'build --only-dependencies' and then "-               ++ "use 'test'."--            -- Interpret the targets on the command line as test targets-            -- (as opposed to say build or haddock targets).-            targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return-                     $ resolveTargets-                         selectPackageTargets-                         selectComponentTarget-                         elaboratedPlan-                         Nothing-                         targetSelectors--            let elaboratedPlan' = pruneInstallPlanToTargets-                                    TargetActionTest-                                    targets-                                    elaboratedPlan-            return (elaboratedPlan', targets)--    printPlan verbosity baseCtx buildCtx--    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx-    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes-  where-    failWhenNoTestSuites = testFailWhenNoTestSuites testFlags-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags---- | This defines what a 'TargetSelector' means for the @test@ command.--- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,--- or otherwise classifies the problem.------ For the @test@ command we select all buildable test-suites,--- or fail if there are no test-suites or no buildable test-suites.----selectPackageTargets  :: TargetSelector-                      -> [AvailableTarget k] -> Either TestTargetProblem [k]-selectPackageTargets targetSelector targets--    -- If there are any buildable test-suite targets then we select those-  | not (null targetsTestsBuildable)-  = Right targetsTestsBuildable--    -- If there are test-suites but none are buildable then we report those-  | not (null targetsTests)-  = Left (TargetProblemNoneEnabled targetSelector targetsTests)--    -- If there are no test-suite but some other targets then we report that-  | not (null targets)-  = Left (noTestsProblem targetSelector)--    -- If there are no targets at all then we report that-  | otherwise-  = Left (TargetProblemNoTargets targetSelector)-  where-    targetsTestsBuildable = selectBuildableTargets-                          . filterTargetsKind TestKind-                          $ targets--    targetsTests          = forgetTargetsDetail-                          . filterTargetsKind TestKind-                          $ targets----- | For a 'TargetComponent' 'TargetSelector', check if the component can be--- selected.------ For the @test@ command we just need to check it is a test-suite, in addition--- to the basic checks on being buildable etc.----selectComponentTarget :: SubComponentTarget-                      -> AvailableTarget k -> Either TestTargetProblem k-selectComponentTarget subtarget@WholeComponent t-  | CTestName _ <- availableTargetComponentName t-  = either Left return $-           selectComponentTargetBasic subtarget t-  | otherwise-  = Left (notTestProblem-           (availableTargetPackageId t)-           (availableTargetComponentName t))--selectComponentTarget subtarget t-  = Left (isSubComponentProblem-           (availableTargetPackageId t)-           (availableTargetComponentName t)-           subtarget)---- | The various error conditions that can occur when matching a--- 'TargetSelector' against 'AvailableTarget's for the @test@ command.----data TestProblem =-     -- | The 'TargetSelector' matches targets but no test-suites-     TargetProblemNoTests     TargetSelector--     -- | The 'TargetSelector' refers to a component that is not a test-suite-   | TargetProblemComponentNotTest PackageId ComponentName--     -- | Asking to test an individual file or module is not supported-   | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget-  deriving (Eq, Show)---type TestTargetProblem = TargetProblem TestProblem---noTestsProblem :: TargetSelector -> TargetProblem TestProblem-noTestsProblem = CustomTargetProblem . TargetProblemNoTests--notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem-notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name--isSubComponentProblem-  :: PackageId-  -> ComponentName-  -> SubComponentTarget-  -> TargetProblem TestProblem-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $-  TargetProblemIsSubComponent pkgid name subcomponent--reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a-reportTargetProblems verbosity failWhenNoTestSuites problems =-  case (failWhenNoTestSuites, problems) of-    (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) ->-      die' verbosity problemsMessage-    (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do-      notice verbosity (renderAllowedNoTestsProblem selector)-      System.Exit.exitSuccess-    (_, _) -> die' verbosity problemsMessage-    where-      problemsMessage = unlines . map renderTestTargetProblem $ problems---- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't---   @die@ when the target problem is 'TargetProblemNoTests'.---   Instead, we display a notice saying that no tests have run and---   indicate how this behaviour was enabled.-renderAllowedNoTestsProblem :: TargetSelector -> String-renderAllowedNoTestsProblem selector =-    "No tests to run for " ++ renderTargetSelector selector--renderTestTargetProblem :: TestTargetProblem -> String-renderTestTargetProblem (TargetProblemNoTargets targetSelector) =-    case targetSelectorFilter targetSelector of-      Just kind | kind /= TestKind-        -> "The test command is for running test suites, but the target '"-           ++ showTargetSelector targetSelector ++ "' refers to "-           ++ renderTargetSelector targetSelector ++ "."-           ++ "\n" ++ show targetSelector--      _ -> renderTargetProblemNoTargets "test" targetSelector-renderTestTargetProblem problem =-    renderTargetProblem "test" renderTestProblem problem---renderTestProblem :: TestProblem -> String-renderTestProblem (TargetProblemNoTests targetSelector) =-    "Cannot run tests for the target '" ++ showTargetSelector targetSelector- ++ "' which refers to " ++ renderTargetSelector targetSelector- ++ " because "- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"- ++ " not contain any test suites."--renderTestProblem (TargetProblemComponentNotTest pkgid cname) =-    "The test command is for running test suites, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ " from the package "- ++ prettyShow pkgid ++ "."-  where-    targetSelector = TargetComponent pkgid cname WholeComponent--renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) =-    "The test command can only run test suites as a whole, "- ++ "not files or modules within them, but the target '"- ++ showTargetSelector targetSelector ++ "' refers to "- ++ renderTargetSelector targetSelector ++ "."-  where-    targetSelector = TargetComponent pkgid cname subtarget
− Distribution/Client/CmdUpdate.hs 
@@ -1,230 +0,0 @@-{-# LANGUAGE CPP             #-}-{-# LANGUAGE LambdaCase      #-}-{-# LANGUAGE NamedFieldPuns  #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections   #-}-{-# LANGUAGE ViewPatterns    #-}---- | cabal-install CLI command: update----module Distribution.Client.CmdUpdate (-    updateCommand,-    updateAction,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.NixStyleOptions-         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )-import Distribution.Client.Compat.Directory-         ( setModificationTime )-import Distribution.Client.ProjectOrchestration-import Distribution.Client.ProjectConfig-         ( ProjectConfig(..)-         , ProjectConfigShared(projectConfigConfigFile)-         , projectConfigWithSolverRepoContext-         , withProjectOrGlobalConfig )-import Distribution.Client.ProjectFlags-         ( ProjectFlags (..) )-import Distribution.Client.Types-         ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName )-import Distribution.Client.HttpUtils-         ( DownloadResult(..) )-import Distribution.Client.FetchUtils-         ( downloadIndex )-import Distribution.Client.JobControl-         ( newParallelJobControl, spawnJob, collectJob )-import Distribution.Client.Setup-         ( GlobalFlags, ConfigFlags(..)-         , UpdateFlags, defaultUpdateFlags-         , RepoContext(..) )-import Distribution.Simple.Flag-         ( fromFlagOrDefault )-import Distribution.Simple.Utils-         ( die', notice, wrapText, writeFileAtomic, noticeNoWrap )-import Distribution.Verbosity-         ( normal, lessVerbose )-import Distribution.Client.IndexUtils.Timestamp-import Distribution.Client.IndexUtils.IndexState-import Distribution.Client.IndexUtils-         ( updateRepoIndexCache, Index(..), writeIndexTimestamp-         , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile )--import qualified Data.Maybe as Unsafe (fromJust)-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp--import qualified Data.ByteString.Lazy       as BS-import Distribution.Client.GZipUtils (maybeDecompress)-import System.FilePath ((<.>), dropExtension)-import Data.Time (getCurrentTime)-import Distribution.Simple.Command-         ( CommandUI(..), usageAlternatives )--import qualified Hackage.Security.Client as Sec--updateCommand :: CommandUI (NixStyleFlags ())-updateCommand = CommandUI-  { commandName         = "v2-update"-  , commandSynopsis     = "Updates list of known packages."-  , commandUsage        = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ]-  , commandDescription  = Just $ \_ -> wrapText $-          "For all known remote repositories, download the package list."--  , commandNotes        = Just $ \pname ->-        "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"-     ++ "the same format and syntax that is supported by the --index-state flag.\n\n"-     ++ "Examples:\n"-     ++ "  " ++ pname ++ " v2-update\n"-     ++ "    Download the package list for all known remote repositories.\n\n"-     ++ "  " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n"-     ++ "  " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"-     ++ "  " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n"-     ++ "  " ++ pname ++ " v2-update hackage.haskell.org\n"-     ++ "    Download hackage.haskell.org at a specific index state.\n\n"-     ++ "  " ++ pname ++ " new update hackage.haskell.org head.hackage\n"-     ++ "    Download hackage.haskell.org and head.hackage\n"-     ++ "    head.hackage must be a known repo-id. E.g. from\n"-     ++ "    your cabal.project(.local) file.\n"--  , commandOptions      = nixStyleOptions $ const []-  , commandDefaultFlags = defaultNixStyleFlags ()-  }--data UpdateRequest = UpdateRequest-  { _updateRequestRepoName  :: RepoName-  , _updateRequestRepoState :: RepoIndexState-  } deriving (Show)--instance Pretty UpdateRequest where-    pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s--instance Parsec UpdateRequest where-  parsec = do-      name <- parsec-      state <- P.char ',' *> parsec <|> pure IndexStateHead-      return (UpdateRequest name state)--updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()-updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do-  let ignoreProject = flagIgnoreProject projectFlags--  projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag-    (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)-    (\globalConfig -> return $ globalConfig <> cliConfig)--  projectConfigWithSolverRepoContext verbosity-    (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)-    $ \repoCtxt -> do--    let repos :: [Repo]-        repos = repoContextRepos repoCtxt--        parseArg :: String -> IO UpdateRequest-        parseArg s = case simpleParsec s of-          Just r -> return r-          Nothing -> die' verbosity $-                     "'v2-update' unable to parse repo: \"" ++ s ++ "\""--    updateRepoRequests <- traverse parseArg extraArgs--    unless (null updateRepoRequests) $ do-      let remoteRepoNames = map repoName repos-          unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests-                            , not (r `elem` remoteRepoNames)]-      unless (null unknownRepos) $-        die' verbosity $ "'v2-update' repo(s): \""-                         ++ intercalate "\", \"" (map unRepoName unknownRepos)-                         ++ "\" can not be found in known remote repo(s): "-                         ++ intercalate ", " (map unRepoName remoteRepoNames)--    let reposToUpdate :: [(Repo, RepoIndexState)]-        reposToUpdate = case updateRepoRequests of-          -- If we are not given any specific repository, update all-          -- repositories to HEAD.-          [] -> map (,IndexStateHead) repos-          updateRequests -> let repoMap = [(repoName r, r) | r <- repos]-                                lookup' k = Unsafe.fromJust (lookup k repoMap)-                            in [ (lookup' name, state)-                               | (UpdateRequest name state) <- updateRequests ]--    case reposToUpdate of-      [] ->-        notice verbosity "No remote repositories configured"-      [(remoteRepo, _)] ->-        notice verbosity $ "Downloading the latest package list from "-                        ++ unRepoName (repoName remoteRepo)-      _ -> notice verbosity . unlines-              $ "Downloading the latest package lists from: "-              : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate--    unless (null reposToUpdate) $ do-      jobCtrl <- newParallelJobControl (length reposToUpdate)-      traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)-        reposToUpdate-      traverse_ (\_ -> collectJob jobCtrl) reposToUpdate--  where-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here-    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)--updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)-           -> IO ()-updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do-  transport <- repoContextGetTransport repoCtxt-  case repo of-    RepoLocalNoIndex{} -> do-      let index = RepoIndex repoCtxt repo-      updatePackageIndexCacheFile verbosity index--    RepoRemote{..} -> do-      downloadResult <- downloadIndex transport verbosity-                        repoRemote repoLocalDir-      case downloadResult of-        FileAlreadyInCache ->-          setModificationTime (indexBaseName repo <.> "tar")-          =<< getCurrentTime-        FileDownloaded indexPath -> do-          writeFileAtomic (dropExtension indexPath) . maybeDecompress-                                                  =<< BS.readFile indexPath-          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)-    RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do-      let index = RepoIndex repoCtxt repo-      -- NB: This may be a nullTimestamp if we've never updated before-      current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo-      -- NB: always update the timestamp, even if we didn't actually-      -- download anything-      writeIndexTimestamp index indexState-      ce <- if repoContextIgnoreExpiry repoCtxt-              then Just `fmap` getCurrentTime-              else return Nothing-      updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce--      let rname = remoteRepoName (repoRemote repo)--      -- Update cabal's internal index as well so that it's not out of sync-      -- (If all access to the cache goes through hackage-security this can go)-      case updated of-        Sec.NoUpdates  -> do-          now <- getCurrentTime-          setModificationTime (indexBaseName repo <.> "tar") now-          noticeNoWrap verbosity $-            "Package list of " ++ prettyShow rname ++-            " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts)--        Sec.HasUpdates -> do-          updateRepoIndexCache verbosity index-          new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo-          noticeNoWrap verbosity $-            "Updated package list of " ++ prettyShow rname ++-            " to the index-state " ++ prettyShow (IndexStateTime new_ts)--          -- TODO: This will print multiple times if there are multiple-          -- repositories: main problem is we don't have a way of updating-          -- a specific repo.  Once we implement that, update this.-          when (current_ts /= nullTimestamp) $-            noticeNoWrap verbosity $-              "To revert to previous state run:\n" ++-              "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"
− Distribution/Client/Compat/Directory.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Compat.Directory (-    setModificationTime,-    createFileLink,-    pathIsSymbolicLink,-    getSymbolicLinkTarget,-    ) where--#if MIN_VERSION_directory(1,2,3)-import System.Directory (setModificationTime)-#else-import Data.Time.Clock (UTCTime)-#endif--#if MIN_VERSION_directory(1,3,1)-import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)-#elif defined(MIN_VERSION_unix)-import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink)-#endif------------------------------------------------------------------------------------ setModificationTime----------------------------------------------------------------------------------#if !MIN_VERSION_directory(1,2,3)--setModificationTime :: FilePath -> UTCTime -> IO ()-setModificationTime _fp _t = return ()--#endif------------------------------------------------------------------------------------ Symlink----------------------------------------------------------------------------------#if MIN_VERSION_directory(1,3,1)-#elif defined(MIN_VERSION_unix)-createFileLink :: FilePath -> FilePath -> IO ()-createFileLink = createSymbolicLink--pathIsSymbolicLink :: FilePath -> IO Bool-pathIsSymbolicLink fp = do-    status <- getSymbolicLinkStatus fp-    return (isSymbolicLink status)--getSymbolicLinkTarget :: FilePath -> IO FilePath-getSymbolicLinkTarget = readSymbolicLink--#else-createFileLink :: FilePath -> FilePath -> IO ()-createFileLink _ _ = fail "Symlinking feature not available"--pathIsSymbolicLink :: FilePath -> IO Bool-pathIsSymbolicLink _ = fail "Symlinking feature not available"--getSymbolicLinkTarget :: FilePath -> IO FilePath-getSymbolicLinkTarget _ = fail "Symlinking feature not available"-#endif
− Distribution/Client/Compat/ExecutablePath.hs 
@@ -1,166 +0,0 @@-{-# 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--import Prelude---- 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---- 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/FilePerms.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-module Distribution.Client.Compat.FilePerms (-  setFileOrdinary,-  setFileExecutable,-  setFileHidden,-  ) where--import Prelude (FilePath, IO, return, ($))--#ifndef mingw32_HOST_OS-import System.Posix.Types-         ( FileMode )-import System.Posix.Internals-         ( c_chmod )-import Foreign.C-         ( withCString-         , throwErrnoPathIfMinus1_ )-#else-import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN)-#endif /* mingw32_HOST_OS */--setFileHidden, setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()-#ifndef mingw32_HOST_OS-setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r---setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x-setFileHidden     _    = return ()--setFileMode :: FilePath -> FileMode -> IO ()-setFileMode name m =-  withCString name $ \s ->-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)-#else-setFileOrdinary   _ = return ()-setFileExecutable _ = return ()-setFileHidden  path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN-#endif
− Distribution/Client/Compat/Orphans.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Distribution.Client.Compat.Orphans () where--import Control.Exception             (SomeException)-import Distribution.Compat.Binary    (Binary (..))-import Distribution.Compat.Typeable  (typeRep)-import Distribution.Utils.Structured (Structure (Nominal), Structured (..))-import Network.URI                   (URI (..), URIAuth (..))-import Prelude                       (error, return)------------------------------------------------------------------------------------ network-uri------------------------------------------------------------------------------------ note, network-uri-2.6.0.3+ provide a Generic instance but earlier--- versions do not, so we use manual Binary instances here-instance Binary URI where-  put (URI a b c d e) = do put a; put b; put c; put d; put e-  get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get-           return (URI a b c d e)--instance Structured URI where-    structure p = Nominal (typeRep p) 0 "URI" []--instance Binary URIAuth where-    put (URIAuth a b c) = do put a; put b; put c-    get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)------------------------------------------------------------------------------------ base------------------------------------------------------------------------------------FIXME: Duncan Coutts: this is a total cheat---Added in 46aa019ec85e313e257d122a3549cce01996c566-instance Binary SomeException where-    put _ = return ()-    get = error "cannot serialise exceptions"--instance Structured SomeException where-    structure p = Nominal (typeRep p) 0 "SomeException" []
− Distribution/Client/Compat/Prelude.hs 
@@ -1,24 +0,0 @@--- to suppress WARNING in "Distribution.Compat.Prelude.Internal"-{-# OPTIONS_GHC -fno-warn-deprecations #-}---- | This module does two things:------ * Acts as a compatibility layer, like @base-compat@.------ * Provides commonly used imports.------ This module is a superset of "Distribution.Compat.Prelude" (which--- this module re-exports)----module Distribution.Client.Compat.Prelude-  ( module Distribution.Compat.Prelude.Internal-  , module X-  ) where--import Distribution.Client.Compat.Orphans ()-import Distribution.Compat.Prelude.Internal-import Prelude ()--import Distribution.Parsec    as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec)-import Distribution.Pretty    as X (Pretty (..), prettyShow)-import Distribution.Verbosity as X (Verbosity)
− Distribution/Client/Compat/Process.hs 
@@ -1,48 +0,0 @@--------------------------------------------------------------------------------- |--- 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--import Prelude (FilePath, IO, String, return, (||))--import           Control.Exception (catch, throw)-import           System.Exit       (ExitCode (ExitFailure))-import           System.IO.Error   (isDoesNotExistError, isPermissionError)-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\" and---   \"permission denied\" exceptions and turns them into---   @ExitFailure@s.------ TODO: this doesn't use 'Distrubution.Compat.Process'.----readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String)-readProcessWithExitCode cmd args input =-  P.readProcessWithExitCode cmd args input-    `catch` \e -> if isDoesNotExistError e || isPermissionError e-                    then return (ExitFailure 127, "", "")-                    else throw e
− Distribution/Client/Compat/Semaphore.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS_GHC -funbox-strict-fields #-}-module Distribution.Client.Compat.Semaphore-    ( QSem-    , newQSem-    , waitQSem-    , signalQSem-    ) where--import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip)--import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,-                               writeTVar)-import Control.Exception (mask_, onException)-import Control.Monad (join, unless)-import Data.Typeable (Typeable)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE---- | 'QSem' is a quantity semaphore in which the resource is aqcuired--- and released in units of one. It provides guaranteed FIFO ordering--- for satisfying blocked `waitQSem` calls.----data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])-  deriving (Eq, Typeable)--newQSem :: Int -> IO QSem-newQSem i = atomically $ do-  q <- newTVar i-  b1 <- newTVar []-  b2 <- newTVar []-  return (QSem q b1 b2)--waitQSem :: QSem -> IO ()-waitQSem s@(QSem q _b1 b2) =-  mask_ $ join $ atomically $ do-        -- join, because if we need to block, we have to add a TVar to-        -- the block queue.-        -- mask_, because we need a chance to set up an exception handler-        -- after the join returns.-     v <- readTVar q-     if v == 0-        then do b <- newTVar False-                ys <- readTVar b2-                writeTVar b2 (b:ys)-                return (wait b)-        else do writeTVar q $! v - 1-                return (return ())-  where-    ---    -- very careful here: if we receive an exception, then we need to-    --  (a) write True into the TVar, so that another signalQSem doesn't-    --      try to wake up this thread, and-    --  (b) if the TVar is *already* True, then we need to do another-    --      signalQSem to avoid losing a unit of the resource.-    ---    -- The 'wake' function does both (a) and (b), so we can just call-    -- it here.-    ---    wait t =-      flip onException (wake s t) $-      atomically $ do-        b <- readTVar t-        unless b retry---wake :: QSem -> TVar Bool -> IO ()-wake s x = join $ atomically $ do-      b <- readTVar x-      if b then return (signalQSem s)-           else do writeTVar x True-                   return (return ())--{-- property we want:--   bracket waitQSem (\_ -> signalQSem) (\_ -> ...)-- never loses a unit of the resource.--}--signalQSem :: QSem -> IO ()-signalQSem s@(QSem q b1 b2) =-  mask_ $ join $ atomically $ do-      -- join, so we don't force the reverse inside the txn-      -- mask_ is needed so we don't lose a wakeup-    v <- readTVar q-    if v /= 0-       then do writeTVar q $! v + 1-               return (return ())-       else do xs <- readTVar b1-               checkwake1 xs-  where-    checkwake1 [] = do-      ys <- readTVar b2-      checkwake2 ys-    checkwake1 (x:xs) = do-      writeTVar b1 xs-      return (wake s x)--    checkwake2 [] = do-      writeTVar q 1-      return (return ())-    checkwake2 (y:ys) = do-      let (z:|zs) = NE.reverse (y:|ys)-      writeTVar b1 zs-      writeTVar b2 []-      return (wake s z)
− Distribution/Client/Config.hs 
@@ -1,1477 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Config--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ Utilities for handling saved state such as known packages, known servers and--- downloaded packages.-------------------------------------------------------------------------------module Distribution.Client.Config (-    SavedConfig(..),-    loadConfig,-    getConfigFilePath,--    showConfig,-    showConfigWithComments,-    parseConfig,--    getCabalDir,-    defaultConfigFile,-    defaultCacheDir,-    defaultCompiler,-    defaultInstallPath,-    defaultLogsDir,-    defaultUserInstall,--    baseSavedConfig,-    commentSavedConfig,-    initialSavedConfig,-    configFieldDescriptions,-    haddockFlagsFields,-    installDirsFields,-    withProgramsFields,-    withProgramOptionsFields,-    userConfigDiff,-    userConfigUpdate,-    createDefaultConfigFile,--    remoteRepoFields,-    postProcessRepo,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Language.Haskell.Extension ( Language(Haskell2010) )--import Distribution.Deprecated.ViewAsFieldDescr-         ( viewAsFieldDescr )--import Distribution.Client.Types-         ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo-         , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps-         , RepoName (..), unRepoName-         )-import Distribution.Client.Types.Credentials (Username (..), Password (..))-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import qualified Distribution.Client.Init.Types as IT-         ( InitFlags(..) )-import qualified Distribution.Client.Init.Defaults as IT-import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand, defaultGlobalFlags-         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags-         , initOptions-         , InstallFlags(..), installOptions, defaultInstallFlags-         , UploadFlags(..), uploadCommand-         , ReportFlags(..), reportCommand )-import Distribution.Client.CmdInstall.ClientInstallFlags-         ( ClientInstallFlags(..), defaultClientInstallFlags-         , clientInstallOptions )-import Distribution.Utils.NubList-         ( NubList, fromNubList, toNubList, overNubList )--import Distribution.Simple.Compiler-         ( DebugInfoLevel(..), OptimisationLevel(..) )-import Distribution.Simple.Setup-         ( ConfigFlags(..), configureOptions, defaultConfigFlags-         , HaddockFlags(..), haddockOptions, defaultHaddockFlags-         , TestFlags(..), defaultTestFlags-         , BenchmarkFlags(..), defaultBenchmarkFlags-         , installDirsOptions, optionDistPref-         , programDbPaths', programDbOptions-         , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Simple.InstallDirs-         ( InstallDirs(..), defaultInstallDirs-         , PathTemplate, toPathTemplate )-import Distribution.Deprecated.ParseUtils-         ( FieldDescr(..), liftField, runP-         , ParseResult(..), PError(..), PWarning(..)-         , locatedErrorMsg, showPWarning-         , readFields, warning, lineNo-         , simpleField, listField, spaceListField-         , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError-         , simpleFieldParsec, listFieldParsec-         )-import Distribution.Client.ParseUtils-         ( parseFields, ppFields, ppSection )-import Distribution.Client.HttpUtils-         ( isOldHackageURI )-import qualified Distribution.Deprecated.ParseUtils as ParseUtils-         ( Field(..) )-import Distribution.Simple.Command-         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) )-import Distribution.Simple.Program-         ( defaultProgramDb )-import Distribution.Simple.Utils-         ( die', notice, warn, lowercase, cabalVersion )-import Distribution.Client.Utils-         ( cabalInstallVersion )-import Distribution.Compiler-         ( CompilerFlavor(..), defaultCompilerFlavor )-import Distribution.Verbosity-         ( normal )-import qualified Distribution.Compat.CharParsing as P-import Distribution.Client.ProjectFlags (ProjectFlags (..))-import Distribution.Solver.Types.ConstraintSource--import qualified Distribution.Deprecated.ReadP as Parse-         ( (<++), option )-import qualified Text.PrettyPrint as Disp-         ( render, text, empty )-import Distribution.Parsec (parsecOptCommaList)-import Text.PrettyPrint-         ( ($+$) )-import Text.PrettyPrint.HughesPJ-         ( text, Doc )-import System.Directory-         ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile )-import Network.URI-         ( URI(..), URIAuth(..), parseURI )-import System.FilePath-         ( (<.>), (</>), takeDirectory )-import System.IO.Error-         ( isDoesNotExistError )-import Distribution.Compat.Environment-         ( getEnvironment, lookupEnv )-import qualified Data.Map as M------- * Configuration saved in the config file-----data SavedConfig = SavedConfig-    { savedGlobalFlags        :: GlobalFlags-    , savedInitFlags          :: IT.InitFlags-    , savedInstallFlags       :: InstallFlags-    , savedClientInstallFlags :: ClientInstallFlags-    , savedConfigureFlags     :: ConfigFlags-    , savedConfigureExFlags   :: ConfigExFlags-    , savedUserInstallDirs    :: InstallDirs (Flag PathTemplate)-    , savedGlobalInstallDirs  :: InstallDirs (Flag PathTemplate)-    , savedUploadFlags        :: UploadFlags-    , savedReportFlags        :: ReportFlags-    , savedHaddockFlags       :: HaddockFlags-    , savedTestFlags          :: TestFlags-    , savedBenchmarkFlags     :: BenchmarkFlags-    , savedProjectFlags       :: ProjectFlags-    } deriving Generic--instance Monoid SavedConfig where-  mempty = gmempty-  mappend = (<>)--instance Semigroup SavedConfig where-  a <> b = SavedConfig {-    savedGlobalFlags       = combinedSavedGlobalFlags,-    savedInitFlags         = combinedSavedInitFlags,-    savedInstallFlags      = combinedSavedInstallFlags,-    savedClientInstallFlags = combinedSavedClientInstallFlags,-    savedConfigureFlags    = combinedSavedConfigureFlags,-    savedConfigureExFlags  = combinedSavedConfigureExFlags,-    savedUserInstallDirs   = combinedSavedUserInstallDirs,-    savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,-    savedUploadFlags       = combinedSavedUploadFlags,-    savedReportFlags       = combinedSavedReportFlags,-    savedHaddockFlags      = combinedSavedHaddockFlags,-    savedTestFlags         = combinedSavedTestFlags,-    savedBenchmarkFlags    = combinedSavedBenchmarkFlags,-    savedProjectFlags      = combinedSavedProjectFlags-  }-    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)--      combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon)-                    -> mon-      combineMonoid 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'--      lastNonMempty'-        :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a-      lastNonMempty'   field subfield =-        let a' = subfield . field $ a-            b' = subfield . field $ b-        in if b' == mempty then a' else b'--      lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)-                      -> NubList a-      lastNonEmptyNL' field subfield =-        let a' = subfield . field $ a-            b' = subfield . field $ b-        in case fromNubList b' of [] -> a'-                                  _  -> b'--      combinedSavedGlobalFlags = GlobalFlags {-        globalVersion           = combine globalVersion,-        globalNumericVersion    = combine globalNumericVersion,-        globalConfigFile        = combine globalConfigFile,-        globalConstraintsFile   = combine globalConstraintsFile,-        globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,-        globalCacheDir          = combine globalCacheDir,-        globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,-        globalActiveRepos       = combine globalActiveRepos,-        globalLogsDir           = combine globalLogsDir,-        globalWorldFile         = combine globalWorldFile,-        globalIgnoreExpiry      = combine globalIgnoreExpiry,-        globalHttpTransport     = combine globalHttpTransport,-        globalNix               = combine globalNix,-        globalStoreDir          = combine globalStoreDir,-        globalProgPathExtra     = lastNonEmptyNL globalProgPathExtra-        }-        where-          combine        = combine'        savedGlobalFlags-          lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags--      combinedSavedInitFlags = IT.InitFlags {-        IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs,-        IT.author              = combine IT.author,-        IT.buildTools          = combineMonoid savedInitFlags IT.buildTools,-        IT.cabalVersion        = combine IT.cabalVersion,-        IT.category            = combine IT.category,-        IT.dependencies        = combineMonoid savedInitFlags IT.dependencies,-        IT.email               = combine IT.email,-        IT.exposedModules      = combineMonoid savedInitFlags IT.exposedModules,-        IT.extraSrc            = combineMonoid savedInitFlags IT.extraSrc,-        IT.homepage            = combine IT.homepage,-        IT.initHcPath          = combine IT.initHcPath,-        IT.initVerbosity       = combine IT.initVerbosity,-        IT.initializeTestSuite = combine IT.initializeTestSuite,-        IT.interactive         = combine IT.interactive,-        IT.language            = combine IT.language,-        IT.license             = combine IT.license,-        IT.mainIs              = combine IT.mainIs,-        IT.minimal             = combine IT.minimal,-        IT.noComments          = combine IT.noComments,-        IT.otherExts           = combineMonoid savedInitFlags IT.otherExts,-        IT.otherModules        = combineMonoid savedInitFlags IT.otherModules,-        IT.overwrite           = combine IT.overwrite,-        IT.packageDir          = combine IT.packageDir,-        IT.packageName         = combine IT.packageName,-        IT.packageType         = combine IT.packageType,-        IT.quiet               = combine IT.quiet,-        IT.simpleProject       = combine IT.simpleProject,-        IT.sourceDirs          = combineMonoid savedInitFlags IT.sourceDirs,-        IT.synopsis            = combine IT.synopsis,-        IT.testDirs            = combineMonoid savedInitFlags IT.testDirs,-        IT.version             = combine IT.version-        }-        where-          combine = combine' savedInitFlags--      combinedSavedInstallFlags = InstallFlags {-        installDocumentation         = combine installDocumentation,-        installHaddockIndex          = combine installHaddockIndex,-        installDryRun                = combine installDryRun,-        installDest                  = combine installDest,-        installMaxBackjumps          = combine installMaxBackjumps,-        installReorderGoals          = combine installReorderGoals,-        installCountConflicts        = combine installCountConflicts,-        installFineGrainedConflicts  = combine installFineGrainedConflicts,-        installMinimizeConflictSet   = combine installMinimizeConflictSet,-        installIndependentGoals      = combine installIndependentGoals,-        installShadowPkgs            = combine installShadowPkgs,-        installStrongFlags           = combine installStrongFlags,-        installAllowBootLibInstalls  = combine installAllowBootLibInstalls,-        installOnlyConstrained       = combine installOnlyConstrained,-        installReinstall             = combine installReinstall,-        installAvoidReinstalls       = combine installAvoidReinstalls,-        installOverrideReinstall     = combine installOverrideReinstall,-        installUpgradeDeps           = combine installUpgradeDeps,-        installOnly                  = combine installOnly,-        installOnlyDeps              = combine installOnlyDeps,-        installIndexState            = combine installIndexState,-        installRootCmd               = combine installRootCmd,-        installSummaryFile           = lastNonEmptyNL installSummaryFile,-        installLogFile               = combine installLogFile,-        installBuildReports          = combine installBuildReports,-        installReportPlanningFailure = combine installReportPlanningFailure,-        installSymlinkBinDir         = combine installSymlinkBinDir,-        installPerComponent          = combine installPerComponent,-        installOneShot               = combine installOneShot,-        installNumJobs               = combine installNumJobs,-        installKeepGoing             = combine installKeepGoing,-        installRunTests              = combine installRunTests,-        installOfflineMode           = combine installOfflineMode-        }-        where-          combine        = combine'        savedInstallFlags-          lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags--      combinedSavedClientInstallFlags = ClientInstallFlags-        { cinstInstallLibs     = combine cinstInstallLibs-        , cinstEnvironmentPath = combine cinstEnvironmentPath-        , cinstOverwritePolicy = combine cinstOverwritePolicy-        , cinstInstallMethod   = combine cinstInstallMethod-        , cinstInstalldir      = combine cinstInstalldir-        }-        where-          combine        = combine'        savedClientInstallFlags--      combinedSavedConfigureFlags = ConfigFlags {-        configArgs                = lastNonEmpty configArgs,-        configPrograms_           = configPrograms_ . savedConfigureFlags $ b,-        -- TODO: NubListify-        configProgramPaths        = lastNonEmpty configProgramPaths,-        -- TODO: NubListify-        configProgramArgs         = lastNonEmpty configProgramArgs,-        configProgramPathExtra    = lastNonEmptyNL configProgramPathExtra,-        configInstantiateWith     = lastNonEmpty configInstantiateWith,-        configHcFlavor            = combine configHcFlavor,-        configHcPath              = combine configHcPath,-        configHcPkg               = combine configHcPkg,-        configVanillaLib          = combine configVanillaLib,-        configProfLib             = combine configProfLib,-        configProf                = combine configProf,-        configSharedLib           = combine configSharedLib,-        configStaticLib           = combine configStaticLib,-        configDynExe              = combine configDynExe,-        configFullyStaticExe      = combine configFullyStaticExe,-        configProfExe             = combine configProfExe,-        configProfDetail          = combine configProfDetail,-        configProfLibDetail       = combine configProfLibDetail,-        -- TODO: NubListify-        configConfigureArgs       = lastNonEmpty configConfigureArgs,-        configOptimization        = combine configOptimization,-        configDebugInfo           = combine configDebugInfo,-        configProgPrefix          = combine configProgPrefix,-        configProgSuffix          = combine configProgSuffix,-        -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.-        configInstallDirs         =-          (configInstallDirs . savedConfigureFlags $ a)-          `mappend` (configInstallDirs . savedConfigureFlags $ b),-        configScratchDir          = combine configScratchDir,-        -- TODO: NubListify-        configExtraLibDirs        = lastNonEmpty configExtraLibDirs,-        -- TODO: NubListify-        configExtraFrameworkDirs  = lastNonEmpty configExtraFrameworkDirs,-        -- TODO: NubListify-        configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,-        configDeterministic       = combine configDeterministic,-        configIPID                = combine configIPID,-        configCID                 = combine configCID,-        configDistPref            = combine configDistPref,-        configCabalFilePath       = combine configCabalFilePath,-        configVerbosity           = combine configVerbosity,-        configUserInstall         = combine configUserInstall,-        -- TODO: NubListify-        configPackageDBs          = lastNonEmpty configPackageDBs,-        configGHCiLib             = combine configGHCiLib,-        configSplitSections       = combine configSplitSections,-        configSplitObjs           = combine configSplitObjs,-        configStripExes           = combine configStripExes,-        configStripLibs           = combine configStripLibs,-        -- TODO: NubListify-        configConstraints         = lastNonEmpty configConstraints,-        -- TODO: NubListify-        configDependencies        = lastNonEmpty configDependencies,-        -- TODO: NubListify-        configConfigurationsFlags = lastNonMempty configConfigurationsFlags,-        configTests               = combine configTests,-        configBenchmarks          = combine configBenchmarks,-        configCoverage            = combine configCoverage,-        configLibCoverage         = combine configLibCoverage,-        configExactConfiguration  = combine configExactConfiguration,-        configFlagError           = combine configFlagError,-        configRelocatable         = combine configRelocatable,-        configUseResponseFiles    = combine configUseResponseFiles,-        configAllowDependingOnPrivateLibs =-            combine configAllowDependingOnPrivateLibs-        }-        where-          combine        = combine'        savedConfigureFlags-          lastNonEmpty   = lastNonEmpty'   savedConfigureFlags-          lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags-          lastNonMempty  = lastNonMempty'  savedConfigureFlags--      combinedSavedConfigureExFlags = ConfigExFlags {-        configCabalVersion  = combine configCabalVersion,-        -- TODO: NubListify-        configExConstraints = lastNonEmpty configExConstraints,-        -- TODO: NubListify-        configPreferences   = lastNonEmpty configPreferences,-        configSolver        = combine configSolver,-        configAllowNewer    =-            combineMonoid savedConfigureExFlags configAllowNewer,-        configAllowOlder    =-            combineMonoid savedConfigureExFlags configAllowOlder,-        configWriteGhcEnvironmentFilesPolicy-                            = combine configWriteGhcEnvironmentFilesPolicy-        }-        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 {-        uploadCandidate   = combine uploadCandidate,-        uploadDoc         = combine uploadDoc,-        uploadUsername    = combine uploadUsername,-        uploadPassword    = combine uploadPassword,-        uploadPasswordCmd = combine uploadPasswordCmd,-        uploadVerbosity   = combine uploadVerbosity-        }-        where-          combine = combine' savedUploadFlags--      combinedSavedReportFlags = ReportFlags {-        reportUsername  = combine reportUsername,-        reportPassword  = combine reportPassword,-        reportVerbosity = combine reportVerbosity-        }-        where-          combine = combine' savedReportFlags--      combinedSavedHaddockFlags = HaddockFlags {-        -- TODO: NubListify-        haddockProgramPaths  = lastNonEmpty haddockProgramPaths,-        -- TODO: NubListify-        haddockProgramArgs   = lastNonEmpty haddockProgramArgs,-        haddockHoogle        = combine haddockHoogle,-        haddockHtml          = combine haddockHtml,-        haddockHtmlLocation  = combine haddockHtmlLocation,-        haddockForHackage    = combine haddockForHackage,-        haddockExecutables   = combine haddockExecutables,-        haddockTestSuites    = combine haddockTestSuites,-        haddockBenchmarks    = combine haddockBenchmarks,-        haddockForeignLibs   = combine haddockForeignLibs,-        haddockInternal      = combine haddockInternal,-        haddockCss           = combine haddockCss,-        haddockLinkedSource  = combine haddockLinkedSource,-        haddockQuickJump     = combine haddockQuickJump,-        haddockHscolourCss   = combine haddockHscolourCss,-        haddockContents      = combine haddockContents,-        haddockDistPref      = combine haddockDistPref,-        haddockKeepTempFiles = combine haddockKeepTempFiles,-        haddockVerbosity     = combine haddockVerbosity,-        haddockCabalFilePath = combine haddockCabalFilePath,-        haddockArgs          = lastNonEmpty haddockArgs-        }-        where-          combine      = combine'        savedHaddockFlags-          lastNonEmpty = lastNonEmpty'   savedHaddockFlags--      combinedSavedTestFlags = TestFlags {-        testDistPref    = combine testDistPref,-        testVerbosity   = combine testVerbosity,-        testHumanLog    = combine testHumanLog,-        testMachineLog  = combine testMachineLog,-        testShowDetails = combine testShowDetails,-        testKeepTix     = combine testKeepTix,-        testWrapper     = combine testWrapper,-        testFailWhenNoTestSuites = combine testFailWhenNoTestSuites,-        testOptions     = lastNonEmpty testOptions-        }-        where-          combine      = combine'        savedTestFlags-          lastNonEmpty = lastNonEmpty'   savedTestFlags--      combinedSavedBenchmarkFlags = BenchmarkFlags {-        benchmarkDistPref  = combine benchmarkDistPref,-        benchmarkVerbosity = combine benchmarkVerbosity,-        benchmarkOptions   = lastNonEmpty benchmarkOptions-        }-        where-          combine      = combine'        savedBenchmarkFlags-          lastNonEmpty = lastNonEmpty'   savedBenchmarkFlags--      combinedSavedProjectFlags = ProjectFlags-        { flagProjectFileName = combine flagProjectFileName-        , flagIgnoreProject   = combine flagIgnoreProject-        }-        where-          combine      = combine'        savedProjectFlags------- * Default config------- | These are the absolute basic defaults. The fields that must be--- initialised. When we load the config from the file we layer the loaded--- values over these ones, so any missing fields in the file take their values--- from here.----baseSavedConfig :: IO SavedConfig-baseSavedConfig = do-  userPrefix <- getCabalDir-  cacheDir   <- defaultCacheDir-  logsDir    <- defaultLogsDir-  worldFile  <- defaultWorldFile-  return mempty {-    savedConfigureFlags  = mempty {-      configHcFlavor     = toFlag defaultCompiler,-      configUserInstall  = toFlag defaultUserInstall,-      configVerbosity    = toFlag normal-    },-    savedUserInstallDirs = mempty {-      prefix             = toFlag (toPathTemplate userPrefix)-    },-    savedGlobalFlags = mempty {-      globalCacheDir     = toFlag cacheDir,-      globalLogsDir      = toFlag logsDir,-      globalWorldFile    = toFlag worldFile-    }-  }---- | This is the initial configuration that we write out to the config file--- if the file does not exist (or the config we use if the file cannot be read--- for some other reason). When the config gets loaded it gets layered on top--- of 'baseSavedConfig' so we do not need to include it into the initial--- values we save into the config file.----initialSavedConfig :: IO SavedConfig-initialSavedConfig = do-  cacheDir    <- defaultCacheDir-  logsDir     <- defaultLogsDir-  worldFile   <- defaultWorldFile-  extraPath   <- defaultExtraPath-  installPath <- defaultInstallPath-  return mempty {-    savedGlobalFlags     = mempty {-      globalCacheDir     = toFlag cacheDir,-      globalRemoteRepos  = toNubList [defaultRemoteRepo],-      globalWorldFile    = toFlag worldFile-    },-    savedConfigureFlags  = mempty {-      configProgramPathExtra = toNubList extraPath-    },-    savedInstallFlags    = mempty {-      installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],-      installBuildReports= toFlag NoReports,-      installNumJobs     = toFlag Nothing-    },-    savedClientInstallFlags = mempty {-      cinstInstalldir = toFlag installPath-    }-  }--defaultCabalDir :: IO FilePath-defaultCabalDir = getAppUserDataDirectory "cabal"--getCabalDir :: IO FilePath-getCabalDir = do-  mDir <- lookupEnv "CABAL_DIR"-  case mDir of-    Nothing -> defaultCabalDir-    Just dir -> return dir--defaultConfigFile :: IO FilePath-defaultConfigFile = do-  dir <- getCabalDir-  return $ dir </> "config"--defaultCacheDir :: IO FilePath-defaultCacheDir = do-  dir <- getCabalDir-  return $ dir </> "packages"--defaultLogsDir :: IO FilePath-defaultLogsDir = do-  dir <- getCabalDir-  return $ dir </> "logs"---- | Default position of the world file-defaultWorldFile :: IO FilePath-defaultWorldFile = do-  dir <- getCabalDir-  return $ dir </> "world"--defaultExtraPath :: IO [FilePath]-defaultExtraPath = do-  dir <- getCabalDir-  return [dir </> "bin"]--defaultInstallPath :: IO FilePath-defaultInstallPath = do-  dir <- getCabalDir-  return (dir </> "bin")--defaultCompiler :: CompilerFlavor-defaultCompiler = fromMaybe GHC defaultCompilerFlavor--defaultUserInstall :: Bool-defaultUserInstall = True--- We do per-user installs by default on all platforms. We used to default to--- global installs on Windows but that no longer works on Windows Vista or 7.--defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False-  where-    str  = "hackage.haskell.org"-    name = RepoName str-    uri  = URI "http:" (Just (URIAuth "" str "")) "/" "" ""-    -- Note that lots of old ~/.cabal/config files will have the old url-    -- http://hackage.haskell.org/packages/archive-    -- but new config files can use the new url (without the /packages/archive)-    -- and avoid having to do a http redirect---- For the default repo we know extra information, fill this in.------ We need this because the 'defaultRemoteRepo' above is only used for the--- first time when a config file is made. So for users with older config files--- we might have only have older info. This lets us fill that in even for old--- config files.----addInfoForKnownRepos :: RemoteRepo -> RemoteRepo-addInfoForKnownRepos repo-  | remoteRepoName repo == remoteRepoName defaultRemoteRepo-  = useSecure . tryHttps . fixOldURI $ repo-  where-    fixOldURI r-      | isOldHackageURI (remoteRepoURI r)-                  = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo }-      | otherwise = r--    tryHttps r = r { remoteRepoShouldTryHttps = True }--    useSecure r@RemoteRepo{-                  remoteRepoSecure       = secure,-                  remoteRepoRootKeys     = [],-                  remoteRepoKeyThreshold = 0-                } | secure /= Just False-            = r {-                -- Use hackage-security by default unless you opt-out with-                -- secure: False-                remoteRepoSecure       = Just True,-                remoteRepoRootKeys     = defaultHackageRemoteRepoKeys,-                remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold-              }-    useSecure r = r-addInfoForKnownRepos other = other---- | The current hackage.haskell.org repo root keys that we ship with cabal.------- This lets us bootstrap trust in this repo without user intervention.--- These keys need to be periodically updated when new root keys are added.--- See the root key procedures for details.----defaultHackageRemoteRepoKeys :: [String]-defaultHackageRemoteRepoKeys =-    [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0",-      "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42",-      "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3",-      "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d",-      "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"-    ]---- | The required threshold of root key signatures for hackage.haskell.org----defaultHackageRemoteRepoKeyThreshold :: Int-defaultHackageRemoteRepoKeyThreshold = 3------- * Config file reading------- | Loads the main configuration, and applies additional defaults to give the--- effective configuration. To loads just what is actually in the config file,--- use 'loadRawConfig'.----loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig-loadConfig verbosity configFileFlag = do-  config <- loadRawConfig verbosity configFileFlag-  extendToEffectiveConfig config--extendToEffectiveConfig :: SavedConfig -> IO SavedConfig-extendToEffectiveConfig config = do-  base <- baseSavedConfig-  let effective0   = base `mappend` config-      globalFlags0 = savedGlobalFlags effective0-      effective  = effective0 {-                     savedGlobalFlags = globalFlags0 {-                       globalRemoteRepos =-                         overNubList (map addInfoForKnownRepos)-                                     (globalRemoteRepos globalFlags0)-                     }-                   }-  return effective---- | Like 'loadConfig' but does not apply any additional defaults, it just--- loads what is actually in the config file. This is thus suitable for--- comparing or editing a config file, but not suitable for using as the--- effective configuration.----loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig-loadRawConfig verbosity configFileFlag = do-  (source, configFile) <- getConfigFilePathAndSource configFileFlag-  minp <- readConfigFile mempty configFile-  case minp of-    Nothing -> do-      notice verbosity $-        "Config file path source is " ++ sourceMsg source ++ "."-      notice verbosity $ "Config file " ++ configFile ++ " not found."-      createDefaultConfigFile verbosity [] configFile-    Just (ParseOk ws conf) -> do-      unless (null ws) $ warn verbosity $-        unlines (map (showPWarning configFile) ws)-      return conf-    Just (ParseFailed err) -> do-      let (line, msg) = locatedErrorMsg err-      die' verbosity $-          "Error parsing config file " ++ configFile-        ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg--  where-    sourceMsg CommandlineOption =   "commandline option"-    sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"-    sourceMsg Default =             "default config file"--data ConfigFileSource = CommandlineOption-                      | EnvironmentVariable-                      | Default---- | Returns the config file path, without checking that the file exists.--- The order of precedence is: input flag, CABAL_CONFIG, default location.-getConfigFilePath :: Flag FilePath -> IO FilePath-getConfigFilePath = fmap snd . getConfigFilePathAndSource--getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)-getConfigFilePathAndSource configFileFlag =-    getSource sources-  where-    sources =-      [ (CommandlineOption,   return . flagToMaybe $ configFileFlag)-      , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)-      , (Default,             Just `liftM` defaultConfigFile) ]--    getSource [] = error "no config file path candidate found."-    getSource ((source,action): xs) =-                      action >>= maybe (getSource xs) (return . (,) source)--readConfigFile-  :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))-readConfigFile initial file = handleNotExists $-  fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)-       (readFile file)--  where-    handleNotExists action = catchIO action $ \ioe ->-      if isDoesNotExistError ioe-        then return Nothing-        else ioError ioe--createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig-createDefaultConfigFile verbosity extraLines filePath  = do-  commentConf <- commentSavedConfig-  initialConf <- initialSavedConfig-  extraConf   <- parseExtraLines verbosity extraLines-  notice verbosity $ "Writing default configuration to " ++ filePath-  writeConfigFile filePath commentConf (initialConf `mappend` extraConf)-  return initialConf--writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()-writeConfigFile file comments vals = do-  let tmpFile = file <.> "tmp"-  createDirectoryIfMissing True (takeDirectory file)-  writeFile tmpFile $-    explanation ++ showConfigWithComments comments vals ++ "\n"-  renameFile tmpFile file-  where-    explanation = unlines-      ["-- This is the configuration file for the 'cabal' command line tool."-      ,"--"-      ,"-- The available configuration options are listed below."-      ,"-- Some of them have default values listed."-      ,"--"-      ,"-- Lines (like this one) beginning with '--' are comments."-      ,"-- Be careful with spaces and indentation because they are"-      ,"-- used to indicate layout for nested sections."-      ,"--"-      ,"-- This config file was generated using the following versions"-      ,"-- of Cabal and cabal-install:"-      ,"-- Cabal library version: " ++ prettyShow cabalVersion-      ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion-      ,"",""-      ]---- | These are the default values that get used in Cabal if a no value is--- given. We use these here to include in comments when we write out the--- initial config file so that the user can see what default value they are--- overriding.----commentSavedConfig :: IO SavedConfig-commentSavedConfig = do-  userInstallDirs   <- defaultInstallDirs defaultCompiler True True-  globalInstallDirs <- defaultInstallDirs defaultCompiler False True-  let conf0 = mempty {-        savedGlobalFlags       = defaultGlobalFlags {-            globalRemoteRepos = toNubList [defaultRemoteRepo]-            },-        savedInitFlags       = mempty {-            IT.interactive     = toFlag False,-            IT.cabalVersion    = toFlag IT.defaultCabalVersion,-            IT.language        = toFlag Haskell2010,-            IT.license         = NoFlag,-            IT.sourceDirs      = Just [IT.defaultSourceDir],-            IT.applicationDirs = Just [IT.defaultApplicationDir]-            },-        savedInstallFlags      = defaultInstallFlags,-        savedClientInstallFlags= defaultClientInstallFlags,-        savedConfigureExFlags  = defaultConfigExFlags {-            configAllowNewer     = Just (AllowNewer mempty),-            configAllowOlder     = Just (AllowOlder mempty)-            },-        savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {-            configUserInstall    = toFlag defaultUserInstall-            },-        savedUserInstallDirs   = fmap toFlag userInstallDirs,-        savedGlobalInstallDirs = fmap toFlag globalInstallDirs,-        savedUploadFlags       = commandDefaultFlags uploadCommand,-        savedReportFlags       = commandDefaultFlags reportCommand,-        savedHaddockFlags      = defaultHaddockFlags,-        savedTestFlags         = defaultTestFlags,-        savedBenchmarkFlags    = defaultBenchmarkFlags-        }-  conf1 <- extendToEffectiveConfig conf0-  let globalFlagsConf1 = savedGlobalFlags conf1-      conf2 = conf1 {-        savedGlobalFlags = globalFlagsConf1 {-            globalRemoteRepos = overNubList (map removeRootKeys)-                                (globalRemoteRepos globalFlagsConf1)-            }-        }-  return conf2-    where-      -- Most people don't want to see default root keys, so don't print them.-      removeRootKeys :: RemoteRepo -> RemoteRepo-      removeRootKeys r = r { remoteRepoRootKeys = [] }---- | All config file fields.----configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]-configFieldDescriptions src =--     toSavedConfig liftGlobalFlag-       (commandOptions (globalCommand []) ParseArgs)-       ["version", "numeric-version", "config-file"] []--  ++ toSavedConfig liftConfigFlag-       (configureOptions ParseArgs)-       (["builddir", "constraint", "dependency", "ipid"]-        ++ map fieldName installDirsFields)--        -- This is only here because viewAsFieldDescr gives us a parser-        -- that only recognises 'ghc' etc, the case-sensitive flag names, not-        -- what the normal case-insensitive parser gives us.-       [simpleFieldParsec "compiler"-          (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag)-          configHcFlavor (\v flags -> flags { configHcFlavor = v })--        -- TODO: The following is a temporary fix. The "optimization"-        -- and "debug-info" fields are OptArg, and viewAsFieldDescr-        -- fails on that. Instead of a hand-written hackaged parser-        -- and printer, we should handle this case properly in the-        -- library.-       ,liftField configOptimization (\v flags ->-                                       flags { configOptimization = v }) $-        let name = "optimization" in-        FieldDescr name-          (\f -> case f of-                   Flag NoOptimisation      -> Disp.text "False"-                   Flag NormalOptimisation  -> Disp.text "True"-                   Flag MaximumOptimisation -> Disp.text "2"-                   _                        -> Disp.empty)-          (\line str _ -> case () of-           _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)-             |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)-             |  str == "0"     -> ParseOk [] (Flag NoOptimisation)-             |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)-             |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)-             | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)-             | lstr == "true"  -> ParseOk [caseWarning]-                                  (Flag NormalOptimisation)-             | otherwise       -> ParseFailed (NoParse name line)-             where-               lstr = lowercase str-               caseWarning = PWarning $-                 "The '" ++ name-                 ++ "' field is case sensitive, use 'True' or 'False'.")-       ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $-        let name = "debug-info" in-        FieldDescr name-          (\f -> case f of-                   Flag NoDebugInfo      -> Disp.text "False"-                   Flag MinimalDebugInfo -> Disp.text "1"-                   Flag NormalDebugInfo  -> Disp.text "True"-                   Flag MaximalDebugInfo -> Disp.text "3"-                   _                     -> Disp.empty)-          (\line str _ -> case () of-           _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)-             |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)-             |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)-             |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)-             |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)-             |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)-             | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)-             | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)-             | otherwise       -> ParseFailed (NoParse name line)-             where-               lstr = lowercase str-               caseWarning = PWarning $-                 "The '" ++ name-                 ++ "' field is case sensitive, use 'True' or 'False'.")-       ]--  ++ toSavedConfig liftConfigExFlag-       (configureExOptions ParseArgs src)-       []-       [let pkgs            = (Just . AllowOlder . RelaxDepsSome)-                              `fmap` parsecOptCommaList parsec-            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)-                               `fmap` parsec) Parse.<++ pkgs-         in simpleField "allow-older"-            (showRelaxDeps . fmap unAllowOlder) parseAllowOlder-            configAllowOlder (\v flags -> flags { configAllowOlder = v })-       ,let pkgs            = (Just . AllowNewer . RelaxDepsSome)-                              `fmap` parsecOptCommaList parsec-            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)-                               `fmap` parsec) Parse.<++ pkgs-         in simpleField "allow-newer"-            (showRelaxDeps . fmap unAllowNewer) parseAllowNewer-            configAllowNewer (\v flags -> flags { configAllowNewer = v })-       ]--  ++ toSavedConfig liftInstallFlag-       (installOptions ParseArgs)-       ["dry-run", "only", "only-dependencies", "dependencies-only"] []--  ++ toSavedConfig liftClientInstallFlag-       (clientInstallOptions ParseArgs)-       [] []--  ++ toSavedConfig liftUploadFlag-       (commandOptions uploadCommand ParseArgs)-       ["verbose", "check", "documentation", "publish"] []--  ++ toSavedConfig liftReportFlag-       (commandOptions reportCommand ParseArgs)-       ["verbose", "username", "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.--  ++ [ viewAsFieldDescr-       $ optionDistPref-       (configDistPref . savedConfigureFlags)-       (\distPref config ->-          config-          { savedConfigureFlags = (savedConfigureFlags config) {-               configDistPref = distPref }-          , savedHaddockFlags = (savedHaddockFlags config) {-               haddockDistPref = distPref }-          }-       )-       ParseArgs-     ]--  where-    toSavedConfig lift options exclusions replacements =-      [ lift (fromMaybe field replacement)-      | opt <- options-      , let field       = viewAsFieldDescr opt-            name        = fieldName field-            replacement = find ((== name) . fieldName) replacements-      , name `notElem` exclusions ]--    showRelaxDeps Nothing                     = mempty-    showRelaxDeps (Just rd) | isRelaxDeps rd  = Disp.text "True"-                            | otherwise       = Disp.text "False"--    toRelaxDeps True  = RelaxDepsAll-    toRelaxDeps False = mempty----- TODO: next step, make the deprecated fields elicit a warning.----deprecatedFieldDescriptions :: [FieldDescr SavedConfig]-deprecatedFieldDescriptions =-  [ liftGlobalFlag $-    listFieldParsec "repos"-      pretty parsec-      (fromNubList . globalRemoteRepos)-      (\rs cfg -> cfg { globalRemoteRepos = toNubList rs })-  , liftGlobalFlag $-    simpleField "cachedir"-      (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)-      globalCacheDir    (\d cfg -> cfg { globalCacheDir = d })-  , liftUploadFlag $-    simpleField "hackage-username"-      (Disp.text . fromFlagOrDefault "" . fmap unUsername)-      (optional (fmap Username parseTokenQ))-      uploadUsername    (\d cfg -> cfg { uploadUsername = d })-  , liftUploadFlag $-    simpleField "hackage-password"-      (Disp.text . fromFlagOrDefault "" . fmap unPassword)-      (optional (fmap Password parseTokenQ))-      uploadPassword    (\d cfg -> cfg { uploadPassword = d })-  , liftUploadFlag $-    spaceListField "hackage-password-command"-      Disp.text parseTokenQ-      (fromFlagOrDefault [] . uploadPasswordCmd)-                        (\d cfg -> cfg { uploadPasswordCmd = Flag d })-  ]- ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)-    installDirsFields- ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs)-    installDirsFields-  where-    optional = Parse.option mempty . fmap toFlag-    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a-    modifyFieldName f d = d { fieldName = f (fieldName d) }--liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))-                    -> FieldDescr SavedConfig-liftUserInstallDirs = liftField-  savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })--liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))-                      -> FieldDescr SavedConfig-liftGlobalInstallDirs =-  liftField savedGlobalInstallDirs-  (\flags conf -> conf { savedGlobalInstallDirs = flags })--liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig-liftGlobalFlag = liftField-  savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })--liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig-liftConfigFlag = liftField-  savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })--liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig-liftConfigExFlag = liftField-  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })--liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig-liftInstallFlag = liftField-  savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })--liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig-liftClientInstallFlag =-  liftField savedClientInstallFlags-  (\flags conf -> conf { savedClientInstallFlags = flags })--liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig-liftUploadFlag = liftField-  savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })--liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig-liftReportFlag = liftField-  savedReportFlags (\flags conf -> conf { savedReportFlags = flags })--parseConfig :: ConstraintSource-            -> SavedConfig-            -> String-            -> ParseResult SavedConfig-parseConfig src initial = \str -> do-  fields <- readFields str-  let (knownSections, others) = partition isKnownSection fields-  config <- parse others-  let init0   = savedInitFlags config-      user0   = savedUserInstallDirs config-      global0 = savedGlobalInstallDirs config-  (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <--    foldM parseSections-          ([], [], savedHaddockFlags config, init0, user0, global0, [], [])-          knownSections--  let remoteRepoSections =-          reverse-        . nubBy ((==) `on` remoteRepoName)-        $ remoteRepoSections0--  let localRepoSections =-          reverse-        . nubBy ((==) `on` localRepoName)-        $ localRepoSections0--  return . fixConfigMultilines $ config {-    savedGlobalFlags       = (savedGlobalFlags config) {-       globalRemoteRepos   = toNubList remoteRepoSections,-       globalLocalNoIndexRepos = toNubList localRepoSections,-       -- the global extra prog path comes from the configure flag prog path-       globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)-       },-    savedConfigureFlags    = (savedConfigureFlags config) {-       configProgramPaths  = paths,-       configProgramArgs   = args-       },-    savedHaddockFlags      = haddockFlags,-    savedInitFlags         = initFlags,-    savedUserInstallDirs   = user,-    savedGlobalInstallDirs = global-  }--  where-    isKnownSection (ParseUtils.Section _ "repository" _ _)              = True-    isKnownSection (ParseUtils.F _ "remote-repo" _)                     = True-    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True-    isKnownSection (ParseUtils.Section _ "init" _ _)                    = True-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True-    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True-    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True-    isKnownSection _                                                    = False--    -- Attempt to split fields that can represent lists of paths into-    -- actual lists on failure, leave the field untouched.-    splitMultiPath :: [String] -> [String]-    splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of-            ParseOk _ res -> res-            _ -> [s]-    splitMultiPath xs = xs--    -- This is a fixup, pending a full config parser rewrite, to-    -- ensure that config fields which can be comma-separated lists-    -- actually parse as comma-separated lists.-    fixConfigMultilines conf = conf {-         savedConfigureFlags =-           let scf = savedConfigureFlags conf-           in  scf {-                     configProgramPathExtra   =-                       toNubList $ splitMultiPath-                       (fromNubList $ configProgramPathExtra scf)-                   , configExtraLibDirs       = splitMultiPath-                                                (configExtraLibDirs scf)-                   , configExtraFrameworkDirs = splitMultiPath-                                                (configExtraFrameworkDirs scf)-                   , configExtraIncludeDirs   = splitMultiPath-                                                (configExtraIncludeDirs scf)-                   , configConfigureArgs      = splitMultiPath-                                                (configConfigureArgs scf)-               }-      }--    parse = parseFields (configFieldDescriptions src-                      ++ deprecatedFieldDescriptions) initial--    parseSections (rs, ls, h, i, u, g, p, a)-                 (ParseUtils.Section lineno "repository" name fs) = do-      name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $-          simpleParsec name-      r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs-      r'' <- postProcessRepo lineno name r'-      case r'' of-          Left local   -> return (rs,        local:ls, h, i, u, g, p, a)-          Right remote -> return (remote:rs, ls,       h, i, u, g, p, a)--    parseSections (rs, ls, h, i, u, g, p, a)-                 (ParseUtils.F lno "remote-repo" raw) = do-      let mr' = simpleParsec raw-      r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'-      return (r':rs, ls, h, i, u, g, p, a)--    parseSections accum@(rs, ls, h, i, u, g, p, a)-                 (ParseUtils.Section _ "haddock" name fs)-      | name == ""        = do h' <- parseFields haddockFlagsFields h fs-                               return (rs, ls, h', i, u, g, p, a)-      | otherwise         = do-          warning "The 'haddock' section should be unnamed"-          return accum--    parseSections accum@(rs, ls, h, i, u, g, p, a)-                 (ParseUtils.Section _ "init" name fs)-      | name == ""        = do i' <- parseFields initFlagsFields i fs-                               return (rs, ls, h, i', u, g, p, a)-      | otherwise         = do-          warning "The 'init' section should be unnamed"-          return accum--    parseSections accum@(rs, ls, h, i, u, g, p, a)-                  (ParseUtils.Section _ "install-dirs" name fs)-      | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (rs, ls, h, i, u', g, p, a)-      | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (rs, ls, h, i, u, g', p, a)-      | otherwise         = do-          warning "The 'install-paths' section should be for 'user' or 'global'"-          return accum-      where name' = lowercase name-    parseSections accum@(rs, ls, h, i, u, g, p, a)-                 (ParseUtils.Section _ "program-locations" name fs)-      | name == ""        = do p' <- parseFields withProgramsFields p fs-                               return (rs, ls, h, i, u, g, p', a)-      | otherwise         = do-          warning "The 'program-locations' section should be unnamed"-          return accum-    parseSections accum@(rs, ls, h, i, u, g, p, a)-                  (ParseUtils.Section _ "program-default-options" name fs)-      | name == ""        = do a' <- parseFields withProgramOptionsFields a fs-                               return (rs, ls, h, i, u, g, 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--postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)-postProcessRepo lineno reponameStr repo0 = do-    when (null reponameStr) $-        syntaxError lineno $ "a 'repository' section requires the "-                          ++ "repository name as an argument"--    reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $-        simpleParsec reponameStr--    case uriScheme (remoteRepoURI repo0) of-        -- TODO: check that there are no authority, query or fragment-        -- Note: the trailing colon is important-        "file+noindex:" -> do-            let uri = remoteRepoURI repo0-            return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")--        _              -> do-            let repo = repo0 { remoteRepoName = reponame }--            when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $-                warning $ "'key-threshold' for repository "-                    ++ show (remoteRepoName repo)-                    ++ " higher than number of keys"--            when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $-                warning $ "'root-keys' for repository "-                    ++ show (remoteRepoName repo)-                    ++ " non-empty, but 'secure' not set to True."--            return $ Right repo--showConfig :: SavedConfig -> String-showConfig = showConfigWithComments mempty--showConfigWithComments :: SavedConfig -> SavedConfig -> String-showConfigWithComments comment vals = Disp.render $-      case fmap (uncurry ppRemoteRepoSection)-           (zip (getRemoteRepos comment) (getRemoteRepos vals)) of-        [] -> Disp.text ""-        (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs-  $+$ Disp.text ""-  $+$ ppFields-      (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))-      mcomment vals-  $+$ Disp.text ""-  $+$ ppSection "haddock" "" haddockFlagsFields-                (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)-  $+$ Disp.text ""-  $+$ ppSection "init" "" initFlagsFields-                (fmap savedInitFlags mcomment) (savedInitFlags vals)-  $+$ Disp.text ""-  $+$ installDirsSection "user"   savedUserInstallDirs-  $+$ Disp.text ""-  $+$ installDirsSection "global" savedGlobalInstallDirs-  $+$ Disp.text ""-  $+$ configFlagsSection "program-locations" withProgramsFields-                         configProgramPaths-  $+$ Disp.text ""-  $+$ configFlagsSection "program-default-options" withProgramOptionsFields-                         configProgramArgs-  where-    getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags-    mcomment = Just comment-    installDirsSection name field =-      ppSection "install-dirs" name installDirsFields-                (fmap field mcomment) (field vals)-    configFlagsSection name fields field =-      ppSection name "" fields-               (fmap (field . savedConfigureFlags) mcomment)-               ((field . savedConfigureFlags) vals)--    -- skip fields based on field name.  currently only skips "remote-repo",-    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)-    skipSomeFields = filter ((/= "remote-repo") . fieldName)---- | Fields for the 'install-dirs' sections.-installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]-installDirsFields = map viewAsFieldDescr installDirsOptions--ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc-ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))-    remoteRepoFields (Just def) vals--remoteRepoFields :: [FieldDescr RemoteRepo]-remoteRepoFields =-  [ simpleField "url"-    (text . show)            (parseTokenQ >>= parseURI')-    remoteRepoURI            (\x repo -> repo { remoteRepoURI = x })-  , simpleFieldParsec "secure"-    showSecure               (Just `fmap` parsec)-    remoteRepoSecure         (\x repo -> repo { remoteRepoSecure = x })-  , listField "root-keys"-    text                     parseTokenQ-    remoteRepoRootKeys       (\x repo -> repo { remoteRepoRootKeys = x })-  , simpleFieldParsec "key-threshold"-    showThreshold            P.integral-    remoteRepoKeyThreshold   (\x repo -> repo { remoteRepoKeyThreshold = x })-  ]-  where-    parseURI' uriString =-      case parseURI uriString of-        Nothing  -> fail $ "remote-repo: no parse on " ++ show uriString-        Just uri -> return uri--    showSecure  Nothing      = mempty       -- default 'secure' setting-    showSecure  (Just True)  = text "True"  -- user explicitly enabled it-    showSecure  (Just False) = text "False" -- user explicitly disabled it--    -- If the key-threshold is set to 0, we omit it as this is the default-    -- and it looks odd to have a value for key-threshold but not for 'secure'-    -- (note that an empty list of keys is already omitted by default, since-    -- that is what we do for all list fields)-    showThreshold 0 = mempty-    showThreshold t = text (show t)---- | 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", "for-hackage"]---- | Fields for the 'init' section.-initFlagsFields :: [FieldDescr IT.InitFlags]-initFlagsFields = [ field-                  | opt <- initOptions ParseArgs-                  , let field = viewAsFieldDescr opt-                        name  = fieldName field-                  , name `notElem` exclusions ]-  where-    exclusions =-      [ "author", "email", "quiet", "no-comments", "minimal", "overwrite"-      , "package-dir", "packagedir", "package-name", "version", "homepage"-      , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe"-      , "simple", "main-is", "expose-module", "exposed-modules", "extension"-      , "dependency", "build-tool", "with-compiler"-      , "verbose"-      ]---- | Fields for the 'program-locations' section.-withProgramsFields :: [FieldDescr [(String, FilePath)]]-withProgramsFields =-  map viewAsFieldDescr $-  programDbPaths' (++ "-location") defaultProgramDb-                             ParseArgs id (++)---- | Fields for the 'program-default-options' section.-withProgramOptionsFields :: [FieldDescr [(String, [String])]]-withProgramOptionsFields =-  map viewAsFieldDescr $-  programDbOptions defaultProgramDb ParseArgs id (++)--parseExtraLines :: Verbosity -> [String] -> IO SavedConfig-parseExtraLines verbosity extraLines =-  case parseConfig (ConstraintSourceMainConfig "additional lines")-       mempty (unlines extraLines) of-    ParseFailed err ->-      let (line, msg) = locatedErrorMsg err-      in die' verbosity $-         "Error parsing additional config lines\n"-         ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg-    ParseOk [] r -> return r-    ParseOk ws _ ->-      die' verbosity $-      unlines (map (showPWarning "Error parsing additional config lines") ws)---- | Get the differences (as a pseudo code diff) between the user's--- '~/.cabal/config' and the one that cabal would generate if it didn't exist.-userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String]-userConfigDiff verbosity globalFlags extraLines = do-  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)-  extraConfig <- parseExtraLines verbosity extraLines-  testConfig <- initialSavedConfig-  return $-    reverse . foldl' createDiff [] . M.toList-    $ M.unionWith combine-      (M.fromList . map justFst $ filterShow testConfig)-      (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))-  where-    justFst (a, b) = (a, (Just b, Nothing))-    justSnd (a, b) = (a, (Nothing, Just b))--    combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)-    combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)-    combine x y = error $ "Can't happen : userConfigDiff "-                  ++ show x ++ " " ++ show y--    createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]-    createDiff acc (key, (Just a, Just b))-        | a == b = acc-        | otherwise = ("+ " ++ key ++ ": " ++ b)-                      : ("- " ++ key ++ ": " ++ a) : acc-    createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc-    createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc-    createDiff acc (_, (Nothing, Nothing)) = acc--    filterShow :: SavedConfig -> [(String, String)]-    filterShow cfg = map keyValueSplit-        . filter (\s -> not (null s) && ':' `elem` s)-        . map nonComment-        . lines-        $ showConfig cfg--    nonComment [] = []-    nonComment ('-':'-':_) = []-    nonComment (x:xs) = x : nonComment xs--    topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace--    keyValueSplit s =-        let (left, right) = break (== ':') s-        in (topAndTail left, topAndTail (drop 1 right))----- | Update the user's ~/.cabal/config' keeping the user's customizations.-userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()-userConfigUpdate verbosity globalFlags extraLines = do-  userConfig  <- loadRawConfig normal (globalConfigFile globalFlags)-  extraConfig <- parseExtraLines verbosity extraLines-  newConfig   <- initialSavedConfig-  commentConf <- commentSavedConfig-  cabalFile <- getConfigFilePath $ globalConfigFile globalFlags-  let backup = cabalFile ++ ".backup"-  notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."-  renameFile cabalFile backup-  notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."-  writeConfigFile cabalFile commentConf-    (newConfig `mappend` userConfig `mappend` extraConfig)
− Distribution/Client/Configure.hs 
@@ -1,464 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Configure--- Copyright   :  (c) David Himmelstrup 2005,---                    Duncan Coutts 2005--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ High level interface to configuring a package.-------------------------------------------------------------------------------module Distribution.Client.Configure (-    configure,-    configureSetupScript,-    chooseCabalVersion,-    checkConfigExFlags,-    -- * Saved configure flags-    readConfigFlagsFrom, readConfigFlags,-    cabalConfigFlagsFile,-    writeConfigFlagsTo, writeConfigFlags,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Distribution.Utils.Generic (safeHead)--import Distribution.Client.Dependency-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)-import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackages, getInstalledPackages )-import Distribution.Client.Setup-         ( ConfigExFlags(..), RepoContext(..)-         , configureCommand, configureExCommand, filterConfigureFlags )-import Distribution.Client.Types as Source-import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Targets-         ( userToPackageConstraint, userConstraintPackageName )-import Distribution.Client.JobControl (Lock)--import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.ConstraintSource-import           Distribution.Solver.Types.LabeledPackageConstraint-import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Solver.Types.PackageIndex-                   ( PackageIndex, elemByPackageName )-import           Distribution.Solver.Types.PkgConfigDb-                   (PkgConfigDb, readPkgConfigDb)-import           Distribution.Solver.Types.SourcePackage--import Distribution.Simple.Compiler-         ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramDb)-import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags )-import Distribution.Simple.Setup-         ( ConfigFlags(..)-         , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Simple.PackageIndex-         ( InstalledPackageIndex, lookupPackageName )-import Distribution.Package-         ( Package(..), packageName, PackageId )-import Distribution.Types.GivenComponent-         ( GivenComponent(..) )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint(..), thisPackageVersionConstraint )-import qualified Distribution.PackageDescription as PkgDesc-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription )-import Distribution.PackageDescription.Configuration-         ( finalizePD )-import Distribution.Version-         ( Version, mkVersion, anyVersion, thisVersion-         , VersionRange, orLaterVersion )-import Distribution.Simple.Utils as Utils-         ( warn, notice, debug, die'-         , defaultPackageDesc )-import Distribution.System-         ( Platform )--import System.FilePath ( (</>) )---- | 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-    -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed-    -- for '--allow-newer' to work.-    allowNewer = isRelaxDeps-                 (maybe mempty unAllowNewer $ configAllowNewer configExFlags)-    allowOlder = isRelaxDeps-                 (maybe mempty unAllowOlder $ configAllowOlder configExFlags)--    defaultVersionRange = if allowOlder || allowNewer-                          then orLaterVersion (mkVersion [1,19,2])-                          else anyVersion---- | Configure the package found in the local directory-configure :: Verbosity-          -> PackageDBStack-          -> RepoContext-          -> Compiler-          -> Platform-          -> ProgramDb-          -> ConfigFlags-          -> ConfigExFlags-          -> [String]-          -> IO ()-configure verbosity packageDBs repoCtxt comp platform progdb-  configFlags configExFlags extraArgs = do--  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-  sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-  pkgConfigDb       <- readPkgConfigDb      verbosity progdb--  checkConfigExFlags verbosity installedPkgIndex-                     (packageIndex sourcePkgDb) configExFlags--  progress <- planLocalPackage verbosity comp platform configFlags configExFlags-                               installedPkgIndex sourcePkgDb pkgConfigDb--  notice verbosity "Resolving dependencies..."-  maybePlan <- foldProgress logMsg (return . Left) (return . Right)-                            progress-  case maybePlan of-    Left message -> do-      warn verbosity $-           "solver failed to find a solution:\n"-        ++ message-        ++ "\nTrying configure anyway."-      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)-        Nothing configureCommand (const configFlags) (const extraArgs)--    Right installPlan0 ->-     let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0-     in case fst (InstallPlan.ready installPlan) of-      [pkg@(ReadyPackage-              (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)-                                 _ _ _))] -> do-        configurePackage verbosity-          platform (compilerInfo comp)-          (setupScriptOptions installedPkgIndex (Just pkg))-          configFlags pkg extraArgs--      _ -> die' verbosity $ "internal error: configure install plan should have exactly "-              ++ "one local ready package."--  where-    setupScriptOptions :: InstalledPackageIndex-                       -> Maybe ReadyPackage-                       -> SetupScriptOptions-    setupScriptOptions =-      configureSetupScript-        packageDBs-        comp-        platform-        progdb-        (fromFlagOrDefault-           (useDistPref defaultSetupScriptOptions)-           (configDistPref configFlags))-        (chooseCabalVersion-           configExFlags-           (flagToMaybe (configCabalVersion configExFlags)))-        Nothing-        False--    logMsg message rest = debug verbosity message >> rest--configureSetupScript :: PackageDBStack-                     -> Compiler-                     -> Platform-                     -> ProgramDb-                     -> FilePath-                     -> VersionRange-                     -> Maybe Lock-                     -> Bool-                     -> InstalledPackageIndex-                     -> Maybe ReadyPackage-                     -> SetupScriptOptions-configureSetupScript packageDBs-                     comp-                     platform-                     progdb-                     distPref-                     cabalVersion-                     lock-                     forceExternal-                     index-                     mpkg-  = SetupScriptOptions {-      useCabalVersion          = cabalVersion-    , useCabalSpecVersion      = Nothing-    , useCompiler              = Just comp-    , usePlatform              = Just platform-    , usePackageDB             = packageDBs'-    , usePackageIndex          = index'-    , useProgramDb             = progdb-    , useDistPref              = distPref-    , useLoggingHandle         = Nothing-    , useWorkingDir            = Nothing-    , useExtraPathEnv          = []-    , useExtraEnvOverrides     = []-    , setupCacheLock           = lock-    , useWin32CleanHack        = False-    , forceExternalSetupMethod = forceExternal-      -- If we have explicit setup dependencies, list them; otherwise, we give-      -- the empty list of dependencies; ideally, we would fix the version of-      -- Cabal here, so that we no longer need the special case for that in-      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet-      -- know the version of Cabal at this point, but only find this there.-      -- Therefore, for now, we just leave this blank.-    , useDependencies          = fromMaybe [] explicitSetupDeps-    , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps-    , useVersionMacros         = not defaultSetupDeps && isJust explicitSetupDeps-    , isInteractive            = False-    }-  where-    -- When we are compiling a legacy setup script without an explicit-    -- setup stanza, we typically want to allow the UserPackageDB for-    -- finding the Cabal lib when compiling any Setup.hs even if we're doing-    -- a global install. However we also allow looking in a specific package-    -- db.-    packageDBs' :: PackageDBStack-    index'      :: Maybe InstalledPackageIndex-    (packageDBs', index') =-      case packageDBs of-        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs-                              , Nothing <- explicitSetupDeps-            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)-        -- but if the user is using an odd db stack, don't touch it-        _otherwise -> (packageDBs, Just index)--    maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo-    maybeSetupBuildInfo = do-      ReadyPackage cpkg <- mpkg-      let gpkg = srcpkgDescription (confPkgSource cpkg)-      PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)--    -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If-    -- so, 'setup-depends' must not be exclusive. See #3199.-    defaultSetupDeps :: Bool-    defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends-                       maybeSetupBuildInfo--    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]-    explicitSetupDeps = do-      -- Check if there is an explicit setup stanza.-      _buildInfo <- maybeSetupBuildInfo-      -- Return the setup dependencies computed by the solver-      ReadyPackage cpkg <- mpkg-      return [ ( cid, srcid )-             | ConfiguredId srcid-               (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid-                 <- CD.setupDeps (confPkgDeps cpkg)-             ]---- | Warn if any constraints or preferences name packages that are not in the--- source package index or installed package index.-checkConfigExFlags :: Package pkg-                   => Verbosity-                   -> InstalledPackageIndex-                   -> PackageIndex pkg-                   -> ConfigExFlags-                   -> IO ()-checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do-  for_ (safeHead unknownConstraints) $ \h ->-    warn verbosity $ "Constraint refers to an unknown package: "-          ++ showConstraint h-  for_ (safeHead unknownPreferences) $ \h ->-    warn verbosity $ "Preference refers to an unknown package: "-          ++ prettyShow h-  where-    unknownConstraints = filter (unknown . userConstraintPackageName . fst) $-                         configExConstraints flags-    unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $-                         configPreferences flags-    unknown pkg = null (lookupPackageName installedPkgIndex pkg)-               && not (elemByPackageName sourcePkgIndex pkg)-    showConstraint (uc, src) =-        prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"---- | Make an 'InstallPlan' for the unpacked package in the current directory,--- and all its dependencies.----planLocalPackage :: Verbosity -> Compiler-                 -> Platform-                 -> ConfigFlags -> ConfigExFlags-                 -> InstalledPackageIndex-                 -> SourcePackageDb-                 -> PkgConfigDb-                 -> IO (Progress String String SolverInstallPlan)-planLocalPackage verbosity comp platform configFlags configExFlags-  installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do-  pkg <- readGenericPackageDescription verbosity =<<-            case flagToMaybe (configCabalFilePath configFlags) of-                Nothing -> defaultPackageDesc verbosity-                Just fp -> return fp-  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)-            (compilerInfo comp)--  let -- We create a local package and ask to resolve a dependency on it-      localPkg = SourcePackage {-        srcpkgPackageId          = packageId pkg,-        srcpkgDescription        = pkg,-        srcpkgSource             = LocalUnpackedPackage ".",-        srcpkgDescrOverride      = Nothing-      }--      testsEnabled = fromFlagOrDefault False $ configTests configFlags-      benchmarksEnabled =-        fromFlagOrDefault False $ configBenchmarks configFlags--      resolverParams =-          removeLowerBounds-          (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)-        . removeUpperBounds-          (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)--        . addPreferences-            -- preferences from the config file or command line-            [ PackageVersionPreference name ver-            | PackageVersionConstraint 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.-            [ LabeledPackageConstraint (userToPackageConstraint uc) src-            | (uc, src) <- configExConstraints configExFlags ]--        . addConstraints-            -- package flags from the config file or command line-            [ let pc = PackageConstraint-                       (scopeToplevel $ packageName pkg)-                       (PackagePropertyFlags $ configConfigurationsFlags configFlags)-              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget-            ]--        . addConstraints-            -- '--enable-tests' and '--enable-benchmarks' constraints from-            -- the config file or command line-            [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .-                       PackagePropertyStanzas $-                       [ TestStanzas  | testsEnabled ] ++-                       [ BenchStanzas | benchmarksEnabled ]-              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget-            ]--            -- Don't solve for executables, since we use an empty source-            -- package database and executables never show up in the-            -- installed package index-        . setSolveExecutables (SolveExecutables False)--        . setSolverVerbosity verbosity--        $ standardInstallPolicy-            installedPkgIndex-            -- NB: We pass in an *empty* source package database,-            -- because cabal configure assumes that all dependencies-            -- have already been installed-            (SourcePackageDb mempty packagePrefs)-            [SpecificSourcePackage localPkg]--  return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)----- | Call an installer for an 'SourcePackage' but override the configure--- 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 -> CompilerInfo-                 -> SetupScriptOptions-                 -> ConfigFlags-                 -> ReadyPackage-                 -> [String]-                 -> IO ()-configurePackage verbosity platform comp scriptOptions configFlags-                 (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))-                 extraArgs =--  setupWrapper verbosity-    scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs)--  where-    gpkg = srcpkgDescription spkg-    configureFlags   = filterConfigureFlags configFlags {-      configIPID = if isJust (flagToMaybe (configIPID configFlags))-                    -- Make sure cabal configure --ipid works.-                    then configIPID configFlags-                    else toFlag (prettyShow ipid),-      configConfigurationsFlags = flags,-      -- 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  = [ thisPackageVersionConstraint srcid-                           | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid-                               <- CD.nonSetupDeps deps ],-      configDependencies = [ GivenComponent (packageName srcid) cname uid-                           | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid-                               <- CD.nonSetupDeps deps ],-      -- Use '--exact-configuration' if supported.-      configExactConfiguration = toFlag True,-      configVerbosity          = toFlag verbosity,-      -- NB: if the user explicitly specified-      -- --enable-tests/--enable-benchmarks, always respect it.-      -- (But if they didn't, let solver decide.)-      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas)-                                    `mappend` configBenchmarks configFlags,-      configTests              = toFlag (TestStanzas `elem` stanzas)-                                    `mappend` configTests configFlags-    }--    pkg = case finalizePD flags (enableStanzas stanzas)-           (const True)-           platform comp [] gpkg of-      Left _ -> error "finalizePD ReadyPackage failed"-      Right (desc, _) -> desc---- -------------------------------------------------------------------------------- * Saved configure environments and flags--- --------------------------------------------------------------------------------- | Read saved configure flags and restore the saved environment from the--- specified files.-readConfigFlagsFrom :: FilePath  -- ^ path to saved flags file-                    -> IO (ConfigFlags, ConfigExFlags)-readConfigFlagsFrom flags = do-  readCommandFlags flags configureExCommand---- | The path (relative to @--build-dir@) where the arguments to @configure@--- should be saved.-cabalConfigFlagsFile :: FilePath -> FilePath-cabalConfigFlagsFile dist = dist </> "cabal-config-flags"---- | Read saved configure flags and restore the saved environment from the--- usual location.-readConfigFlags :: FilePath  -- ^ @--build-dir@-                -> IO (ConfigFlags, ConfigExFlags)-readConfigFlags dist =-  readConfigFlagsFrom (cabalConfigFlagsFile dist)---- | Save the configure flags and environment to the specified files.-writeConfigFlagsTo :: FilePath  -- ^ path to saved flags file-                   -> Verbosity -> (ConfigFlags, ConfigExFlags)-                   -> IO ()-writeConfigFlagsTo file verb flags = do-  writeCommandFlags verb file configureExCommand flags---- | Save the build flags to the usual location.-writeConfigFlags :: Verbosity-                 -> FilePath  -- ^ @--build-dir@-                 -> (ConfigFlags, ConfigExFlags) -> IO ()-writeConfigFlags verb dist =-  writeConfigFlagsTo (cabalConfigFlagsFile dist) verb
− Distribution/Client/Dependency.hs 
@@ -1,1053 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007---                    Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Top level interface to dependency resolution.-------------------------------------------------------------------------------module Distribution.Client.Dependency (-    -- * The main package dependency resolver-    chooseSolver,-    resolveDependencies,-    Progress(..),-    foldProgress,--    -- * Alternate, simple resolver that does not do dependencies recursively-    resolveWithoutDependencies,--    -- * Constructing resolver policies-    PackageProperty(..),-    PackageConstraint(..),-    scopeToplevel,-    PackagesPreferenceDefault(..),-    PackagePreference(..),--    -- ** Standard policy-    basicInstallPolicy,-    standardInstallPolicy,-    PackageSpecifier(..),--    -- ** Extra policy options-    upgradeDependencies,-    reinstallTargets,--    -- ** Policy utils-    addConstraints,-    addPreferences,-    setPreferenceDefault,-    setReorderGoals,-    setCountConflicts,-    setFineGrainedConflicts,-    setMinimizeConflictSet,-    setIndependentGoals,-    setAvoidReinstalls,-    setShadowPkgs,-    setStrongFlags,-    setAllowBootLibInstalls,-    setOnlyConstrained,-    setMaxBackjumps,-    setEnableBackjumping,-    setSolveExecutables,-    setGoalOrder,-    setSolverVerbosity,-    removeLowerBounds,-    removeUpperBounds,-    addDefaultSetupDependencies,-    addSetupCabalMinVersionConstraint,-    addSetupCabalMaxVersionConstraint,-  ) where--import Distribution.Client.Compat.Prelude-import qualified Prelude as Unsafe (head)--import Distribution.Solver.Modular-         ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) )-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan-import Distribution.Client.Types-         ( SourcePackageDb(SourcePackageDb)-         , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints-         , UnresolvedPkgLoc, UnresolvedSourcePackage-         , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..)-         , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps-         )-import Distribution.Client.Dependency.Types-         ( PreSolver(..), Solver(..)-         , PackagesPreferenceDefault(..) )-import Distribution.Package-         ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId-         , Package(..), packageName, packageVersion )-import Distribution.Types.Dependency-import qualified Distribution.PackageDescription as PD-import qualified Distribution.PackageDescription.Configuration as PD-import Distribution.PackageDescription.Configuration-         ( finalizePD )-import Distribution.Compiler-         ( CompilerInfo(..) )-import Distribution.System-         ( Platform )-import Distribution.Client.Utils-         ( duplicatesBy, mergeBy, MergeResult(..) )-import Distribution.Simple.Setup-         ( asBool )-import Distribution.Verbosity-         ( normal  )-import Distribution.Version-import qualified Distribution.Compat.Graph as Graph--import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.ConstraintSource-import           Distribution.Solver.Types.DependencyResolver-import           Distribution.Solver.Types.InstalledPreference-import           Distribution.Solver.Types.LabeledPackageConstraint-import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Solver.Types.PackageConstraint-import           Distribution.Solver.Types.PackagePath-import           Distribution.Solver.Types.PackagePreferences-import qualified Distribution.Solver.Types.PackageIndex as PackageIndex-import           Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)-import           Distribution.Solver.Types.Progress-import           Distribution.Solver.Types.ResolverPackage-import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.SolverId-import           Distribution.Solver.Types.SolverPackage-import           Distribution.Solver.Types.SourcePackage-import           Distribution.Solver.Types.Variable--import Data.List-         ( maximumBy )-import qualified Data.Map as Map-import qualified Data.Set as Set-import Control.Exception-         ( assert )----- --------------------------------------------------------------- * High level planner policy--- ---------------------------------------------------------------- | The set of parameters to the dependency resolver. These parameters are--- relatively low level but many kinds of high level policies can be--- implemented in terms of adjustments to the parameters.----data DepResolverParams = DepResolverParams {-       depResolverTargets           :: Set PackageName,-       depResolverConstraints       :: [LabeledPackageConstraint],-       depResolverPreferences       :: [PackagePreference],-       depResolverPreferenceDefault :: PackagesPreferenceDefault,-       depResolverInstalledPkgIndex :: InstalledPackageIndex,-       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex UnresolvedSourcePackage,-       depResolverReorderGoals      :: ReorderGoals,-       depResolverCountConflicts    :: CountConflicts,-       depResolverFineGrainedConflicts :: FineGrainedConflicts,-       depResolverMinimizeConflictSet :: MinimizeConflictSet,-       depResolverIndependentGoals  :: IndependentGoals,-       depResolverAvoidReinstalls   :: AvoidReinstalls,-       depResolverShadowPkgs        :: ShadowPkgs,-       depResolverStrongFlags       :: StrongFlags,--       -- | Whether to allow base and its dependencies to be installed.-       depResolverAllowBootLibInstalls :: AllowBootLibInstalls,--       -- | Whether to only allow explicitly constrained packages plus-       -- goals or to allow any package.-       depResolverOnlyConstrained   :: OnlyConstrained,--       depResolverMaxBackjumps      :: Maybe Int,-       depResolverEnableBackjumping :: EnableBackjumping,-       -- | Whether or not to solve for dependencies on executables.-       -- This should be true, except in the legacy code path where-       -- we can't tell if an executable has been installed or not,-       -- so we shouldn't solve for them.  See #3875.-       depResolverSolveExecutables  :: SolveExecutables,--       -- | Function to override the solver's goal-ordering heuristics.-       depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering),-       depResolverVerbosity         :: Verbosity-     }--showDepResolverParams :: DepResolverParams -> String-showDepResolverParams p =-     "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))-  ++ "\nconstraints: "-  ++   concatMap (("\n  " ++) . showLabeledConstraint)-       (depResolverConstraints p)-  ++ "\npreferences: "-  ++   concatMap (("\n  " ++) . showPackagePreference)-       (depResolverPreferences p)-  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault        p)-  ++ "\nreorder goals: "     ++ show (asBool (depResolverReorderGoals     p))-  ++ "\ncount conflicts: "   ++ show (asBool (depResolverCountConflicts   p))-  ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p))-  ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p))-  ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p))-  ++ "\navoid reinstalls: "  ++ show (asBool (depResolverAvoidReinstalls  p))-  ++ "\nshadow packages: "   ++ show (asBool (depResolverShadowPkgs       p))-  ++ "\nstrong flags: "      ++ show (asBool (depResolverStrongFlags      p))-  ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p))-  ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p)-  ++ "\nmax backjumps: "     ++ maybe "infinite" show-                                     (depResolverMaxBackjumps             p)-  where-    showLabeledConstraint :: LabeledPackageConstraint -> String-    showLabeledConstraint (LabeledPackageConstraint pc src) =-        showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"---- | A package selection preference for a particular package.------ Preferences are soft constraints that the dependency resolver should try to--- respect where possible. It is not specified if preferences on some packages--- are more important than others.----data PackagePreference =--     -- | A suggested constraint on the version number.-     PackageVersionPreference   PackageName VersionRange--     -- | If we prefer versions of packages that are already installed.-   | PackageInstalledPreference PackageName InstalledPreference--     -- | If we would prefer to enable these optional stanzas-     -- (i.e. test suites and/or benchmarks)-   | PackageStanzasPreference   PackageName [OptionalStanza]----- | Provide a textual representation of a package preference--- for debugging purposes.----showPackagePreference :: PackagePreference -> String-showPackagePreference (PackageVersionPreference   pn vr) =-  prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr)-showPackagePreference (PackageInstalledPreference pn ip) =-  prettyShow pn ++ " " ++ show ip-showPackagePreference (PackageStanzasPreference pn st) =-  prettyShow pn ++ " " ++ show st--basicDepResolverParams :: InstalledPackageIndex-                       -> PackageIndex.PackageIndex UnresolvedSourcePackage-                       -> DepResolverParams-basicDepResolverParams installedPkgIndex sourcePkgIndex =-    DepResolverParams {-       depResolverTargets           = Set.empty,-       depResolverConstraints       = [],-       depResolverPreferences       = [],-       depResolverPreferenceDefault = PreferLatestForSelected,-       depResolverInstalledPkgIndex = installedPkgIndex,-       depResolverSourcePkgIndex    = sourcePkgIndex,-       depResolverReorderGoals      = ReorderGoals False,-       depResolverCountConflicts    = CountConflicts True,-       depResolverFineGrainedConflicts = FineGrainedConflicts True,-       depResolverMinimizeConflictSet = MinimizeConflictSet False,-       depResolverIndependentGoals  = IndependentGoals False,-       depResolverAvoidReinstalls   = AvoidReinstalls False,-       depResolverShadowPkgs        = ShadowPkgs False,-       depResolverStrongFlags       = StrongFlags False,-       depResolverAllowBootLibInstalls = AllowBootLibInstalls False,-       depResolverOnlyConstrained   = OnlyConstrainedNone,-       depResolverMaxBackjumps      = Nothing,-       depResolverEnableBackjumping = EnableBackjumping True,-       depResolverSolveExecutables  = SolveExecutables True,-       depResolverGoalOrder         = Nothing,-       depResolverVerbosity         = normal-     }--addTargets :: [PackageName]-           -> DepResolverParams -> DepResolverParams-addTargets extraTargets params =-    params {-      depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params-    }--addConstraints :: [LabeledPackageConstraint]-               -> DepResolverParams -> DepResolverParams-addConstraints extraConstraints params =-    params {-      depResolverConstraints = extraConstraints-                            ++ depResolverConstraints params-    }--addPreferences :: [PackagePreference]-               -> DepResolverParams -> DepResolverParams-addPreferences extraPreferences params =-    params {-      depResolverPreferences = extraPreferences-                            ++ depResolverPreferences params-    }--setPreferenceDefault :: PackagesPreferenceDefault-                     -> DepResolverParams -> DepResolverParams-setPreferenceDefault preferenceDefault params =-    params {-      depResolverPreferenceDefault = preferenceDefault-    }--setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams-setReorderGoals reorder params =-    params {-      depResolverReorderGoals = reorder-    }--setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams-setCountConflicts count params =-    params {-      depResolverCountConflicts = count-    }--setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams-setFineGrainedConflicts fineGrained params =-    params {-      depResolverFineGrainedConflicts = fineGrained-    }--setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams-setMinimizeConflictSet minimize params =-    params {-      depResolverMinimizeConflictSet = minimize-    }--setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams-setIndependentGoals indep params =-    params {-      depResolverIndependentGoals = indep-    }--setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams-setAvoidReinstalls avoid params =-    params {-      depResolverAvoidReinstalls = avoid-    }--setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams-setShadowPkgs shadow params =-    params {-      depResolverShadowPkgs = shadow-    }--setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams-setStrongFlags sf params =-    params {-      depResolverStrongFlags = sf-    }--setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams-setAllowBootLibInstalls i params =-    params {-      depResolverAllowBootLibInstalls = i-    }--setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams-setOnlyConstrained i params =-  params {-    depResolverOnlyConstrained = i-  }--setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams-setMaxBackjumps n params =-    params {-      depResolverMaxBackjumps = n-    }--setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams-setEnableBackjumping b params =-    params {-      depResolverEnableBackjumping = b-    }--setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams-setSolveExecutables b params =-    params {-      depResolverSolveExecutables = b-    }--setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)-             -> DepResolverParams-             -> DepResolverParams-setGoalOrder order params =-    params {-      depResolverGoalOrder = order-    }--setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams-setSolverVerbosity verbosity params =-    params {-      depResolverVerbosity = verbosity-    }---- | Some packages are specific to a given compiler version and should never be--- upgraded.-dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams-dontUpgradeNonUpgradeablePackages params =-    addConstraints extraConstraints params-  where-    extraConstraints =-      [ LabeledPackageConstraint-        (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)-        ConstraintSourceNonUpgradeablePackage-      | Set.notMember (mkPackageName "base") (depResolverTargets params)-      -- If you change this enumeration, make sure to update the list in-      -- "Distribution.Solver.Modular.Solver" as well-      , pkgname <- [ mkPackageName "base"-                   , mkPackageName "ghc-bignum"-                   , mkPackageName "ghc-prim"-                   , mkPackageName "integer-gmp"-                   , mkPackageName "integer-simple"-                   , mkPackageName "template-haskell"-                   ]-      , isInstalled pkgname ]--    isInstalled = not . null-                . InstalledPackageIndex.lookupPackageName-                                 (depResolverInstalledPkgIndex params)--addSourcePackages :: [UnresolvedSourcePackage]-                  -> DepResolverParams -> DepResolverParams-addSourcePackages pkgs params =-    params {-      depResolverSourcePkgIndex =-        foldl (flip PackageIndex.insert)-              (depResolverSourcePkgIndex params) pkgs-    }--hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]-                                                  -> DepResolverParams-                                                  -> DepResolverParams-hideInstalledPackagesSpecificBySourcePackageId pkgids params =-    --TODO: this should work using exclude constraints instead-    params {-      depResolverInstalledPkgIndex =-        foldl' (flip InstalledPackageIndex.deleteSourcePackageId)-               (depResolverInstalledPkgIndex params) pkgids-    }--hideInstalledPackagesAllVersions :: [PackageName]-                                 -> DepResolverParams -> DepResolverParams-hideInstalledPackagesAllVersions pkgnames params =-    --TODO: this should work using exclude constraints instead-    params {-      depResolverInstalledPkgIndex =-        foldl' (flip InstalledPackageIndex.deletePackageName)-               (depResolverInstalledPkgIndex params) pkgnames-    }----- | Remove upper bounds in dependencies using the policy specified by the--- 'AllowNewer' argument (all/some/none).------ Note: It's important to apply 'removeUpperBounds' after--- 'addSourcePackages'. Otherwise, the packages inserted by--- 'addSourcePackages' won't have upper bounds in dependencies relaxed.----removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams-removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps---- | Dual of 'removeUpperBounds'-removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams-removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps--data RelaxKind = RelaxLower | RelaxUpper---- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'-removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams-removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation-removeBounds  relKind relDeps            params =-    params {-      depResolverSourcePkgIndex = sourcePkgIndex'-    }-  where-    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params--    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage-    relaxDeps srcPkg = srcPkg-      { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg)-      }---- | Relax the dependencies of this package if needed.------ Helper function used by 'removeBounds'-relaxPackageDeps :: RelaxKind-                 -> RelaxDeps-                 -> PD.GenericPackageDescription -> PD.GenericPackageDescription-relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'-relaxPackageDeps relKind RelaxDepsAll  gpd = PD.transformAllBuildDepends relaxAll gpd-  where-    relaxAll :: Dependency -> Dependency-    relaxAll (Dependency pkgName verRange cs) =-        Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs--relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =-  PD.transformAllBuildDepends relaxSome gpd-  where-    thisPkgName    = packageName gpd-    thisPkgId      = packageId   gpd-    depsToRelax    = Map.fromList $ mapMaybe f depsToRelax0--    f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod)-    f (RelaxedDep scope rdm p) = case scope of-      RelaxDepScopeAll        -> Just (p,rdm)-      RelaxDepScopePackage p0-          | p0 == thisPkgName -> Just (p,rdm)-          | otherwise         -> Nothing-      RelaxDepScopePackageId p0-          | p0 == thisPkgId   -> Just (p,rdm)-          | otherwise         -> Nothing--    relaxSome :: Dependency -> Dependency-    relaxSome d@(Dependency depName verRange cs)-        | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =-            -- a '*'-subject acts absorbing, for consistency with-            -- the 'Semigroup RelaxDeps' instance-            Dependency depName (removeBound relKind relMod verRange) cs-        | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =-            Dependency depName (removeBound relKind relMod verRange) cs-        | otherwise = d -- no-op---- | Internal helper for 'relaxPackageDeps'-removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange-removeBound RelaxLower RelaxDepModNone = removeLowerBound-removeBound RelaxUpper RelaxDepModNone = removeUpperBound-removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange-  where-    embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v)-    embed vr                     = embedVersionRange vr--    -- This function is the interesting part as it defines the meaning-    -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints;-    caretTransformation l u = case relKind of-      RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@-      RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@---- | Supply defaults for packages without explicit Setup dependencies------ Note: It's important to apply 'addDefaultSetupDepends' after--- 'addSourcePackages'. Otherwise, the packages inserted by--- 'addSourcePackages' won't have upper bounds in dependencies relaxed.----addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])-                            -> DepResolverParams -> DepResolverParams-addDefaultSetupDependencies defaultSetupDeps params =-    params {-      depResolverSourcePkgIndex =-        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)-    }-  where-    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage-    applyDefaultSetupDeps srcpkg =-        srcpkg {-          srcpkgDescription = gpkgdesc {-            PD.packageDescription = pkgdesc {-              PD.setupBuildInfo =-                case PD.setupBuildInfo pkgdesc of-                  Just sbi -> Just sbi-                  Nothing -> case defaultSetupDeps srcpkg of-                    Nothing -> Nothing-                    Just deps | isCustom -> Just PD.SetupBuildInfo {-                                                PD.defaultSetupDepends = True,-                                                PD.setupDepends        = deps-                                            }-                              | otherwise -> Nothing-            }-          }-        }-      where-        isCustom = PD.buildType pkgdesc == PD.Custom-        gpkgdesc = srcpkgDescription srcpkg-        pkgdesc  = PD.packageDescription gpkgdesc---- | If a package has a custom setup then we need to add a setup-depends--- on Cabal.----addSetupCabalMinVersionConstraint :: Version-                                  -> DepResolverParams -> DepResolverParams-addSetupCabalMinVersionConstraint minVersion =-    addConstraints-      [ LabeledPackageConstraint-          (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)-                             (PackagePropertyVersion $ orLaterVersion minVersion))-          ConstraintSetupCabalMinVersion-      ]-  where-    cabalPkgname = mkPackageName "Cabal"---- | Variant of 'addSetupCabalMinVersionConstraint' which sets an--- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'.----addSetupCabalMaxVersionConstraint :: Version-                                  -> DepResolverParams -> DepResolverParams-addSetupCabalMaxVersionConstraint maxVersion =-    addConstraints-      [ LabeledPackageConstraint-          (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)-                             (PackagePropertyVersion $ earlierVersion maxVersion))-          ConstraintSetupCabalMaxVersion-      ]-  where-    cabalPkgname = mkPackageName "Cabal"---upgradeDependencies :: DepResolverParams -> DepResolverParams-upgradeDependencies = setPreferenceDefault PreferAllLatest---reinstallTargets :: DepResolverParams -> DepResolverParams-reinstallTargets params =-    hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params----- | A basic solver policy on which all others are built.----basicInstallPolicy :: InstalledPackageIndex-                   -> SourcePackageDb-                   -> [PackageSpecifier UnresolvedSourcePackage]-                   -> DepResolverParams-basicInstallPolicy-    installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)-    pkgSpecifiers--  = addPreferences-      [ PackageVersionPreference name ver-      | (name, ver) <- Map.toList sourcePkgPrefs ]--  . addConstraints-      (concatMap pkgSpecifierConstraints pkgSpecifiers)--  . addTargets-      (map pkgSpecifierTarget pkgSpecifiers)--  . hideInstalledPackagesSpecificBySourcePackageId-      [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]--  . addSourcePackages-      [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]--  $ basicDepResolverParams-      installedPkgIndex sourcePkgIndex----- | The policy used by all the standard commands, install, fetch, freeze etc--- (but not the v2-build and related commands).------ It extends the 'basicInstallPolicy' with a policy on setup deps.----standardInstallPolicy :: InstalledPackageIndex-                      -> SourcePackageDb-                      -> [PackageSpecifier UnresolvedSourcePackage]-                      -> DepResolverParams-standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers--  = addDefaultSetupDependencies mkDefaultSetupDeps--  $ basicInstallPolicy-      installedPkgIndex sourcePkgDb pkgSpecifiers--    where-      -- Force Cabal >= 1.24 dep when the package is affected by #3199.-      mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]-      mkDefaultSetupDeps srcpkg | affected        =-        Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet]-                                | otherwise       = Nothing-        where-          gpkgdesc = srcpkgDescription srcpkg-          pkgdesc  = PD.packageDescription gpkgdesc-          bt       = PD.buildType pkgdesc-          affected = bt == PD.Custom && hasBuildableFalse gpkgdesc--      -- Does this package contain any components with non-empty 'build-depends'-      -- and a 'buildable' field that could potentially be set to 'False'? False-      -- positives are possible.-      hasBuildableFalse :: PD.GenericPackageDescription -> Bool-      hasBuildableFalse gpkg =-        not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))-        where-          buildableConditions      = PD.extractConditions PD.buildable gpkg-          noDepConditions          = PD.extractConditions-                                     (null . PD.targetBuildDepends)    gpkg-          alwaysTrue (PD.Lit True) = True-          alwaysTrue _             = False---- --------------------------------------------------------------- * Interface to the standard resolver--- --------------------------------------------------------------chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver-chooseSolver _verbosity preSolver _cinfo =-    case preSolver of-      AlwaysModular -> do-        return Modular--runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc-runSolver Modular = modularResolver---- | Run the dependency solver.------ Since this is potentially an expensive operation, the result is wrapped in a--- a 'Progress' structure that can be unfolded to provide progress information,--- logging messages and the final result or an error.----resolveDependencies :: Platform-                    -> CompilerInfo-                    -> PkgConfigDb-                    -> Solver-                    -> DepResolverParams-                    -> Progress String String SolverInstallPlan--    --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages-resolveDependencies platform comp _pkgConfigDB _solver params-  | Set.null (depResolverTargets params)-  = return (validateSolverResult platform comp indGoals [])-  where-    indGoals = depResolverIndependentGoals params--resolveDependencies platform comp pkgConfigDB solver params =--    Step (showDepResolverParams finalparams)-  $ fmap (validateSolverResult platform comp indGoals)-  $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize-                      indGoals noReinstalls-                      shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj-                      solveExes order verbosity (PruneAfterFirstSuccess False))-                     platform comp installedPkgIndex sourcePkgIndex-                     pkgConfigDB preferences constraints targets-  where--    finalparams@(DepResolverParams-      targets constraints-      prefs defpref-      installedPkgIndex-      sourcePkgIndex-      reordGoals-      cntConflicts-      fineGrained-      minimize-      indGoals-      noReinstalls-      shadowing-      strFlags-      allowBootLibs-      onlyConstrained_-      maxBkjumps-      enableBj-      solveExes-      order-      verbosity) =-        if asBool (depResolverAllowBootLibInstalls params)-        then params-        else dontUpgradeNonUpgradeablePackages params--    preferences = interpretPackagesPreference targets defpref prefs----- | Give an interpretation to the global 'PackagesPreference' as---  specific per-package 'PackageVersionPreference'.----interpretPackagesPreference :: Set PackageName-                            -> PackagesPreferenceDefault-                            -> [PackagePreference]-                            -> (PackageName -> PackagePreferences)-interpretPackagesPreference selected defaultPref prefs =-  \pkgname -> PackagePreferences (versionPref pkgname)-                                 (installPref pkgname)-                                 (stanzasPref pkgname)-  where-    versionPref pkgname =-      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)-    versionPrefs = Map.fromListWith (++)-                   [(pkgname, [pref])-                   | PackageVersionPreference pkgname pref <- prefs]--    installPref pkgname =-      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)-    installPrefs = Map.fromList-      [ (pkgname, pref)-      | PackageInstalledPreference pkgname pref <- prefs ]-    installPrefDefault = case defaultPref of-      PreferAllLatest         -> const PreferLatest-      PreferAllInstalled      -> const PreferInstalled-      PreferLatestForSelected -> \pkgname ->-        -- When you say cabal install foo, what you really mean is, prefer the-        -- latest version of foo, but the installed version of everything else-        if pkgname `Set.member` selected then PreferLatest-                                         else PreferInstalled--    stanzasPref pkgname =-      fromMaybe [] (Map.lookup pkgname stanzasPrefs)-    stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))-      [ (pkgname, pref)-      | PackageStanzasPreference pkgname pref <- prefs ]----- --------------------------------------------------------------- * Checking the result of the solver--- ---------------------------------------------------------------- | 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.----validateSolverResult :: Platform-                     -> CompilerInfo-                     -> IndependentGoals-                     -> [ResolverPackage UnresolvedPkgLoc]-                     -> SolverInstallPlan-validateSolverResult platform comp indepGoals pkgs =-    case planPackagesProblems platform comp pkgs of-      [] -> case SolverInstallPlan.new indepGoals graph of-              Right plan     -> plan-              Left  problems -> error (formatPlanProblems problems)-      problems               -> error (formatPkgProblems problems)--  where-    graph = Graph.fromDistinctList pkgs--    formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem-    formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem--    formatProblemMessage problems =-      unlines $-        "internal error: could not construct a valid install plan."-      : "The proposed (invalid) plan contained the following problems:"-      : problems-      ++ "Proposed plan:"-      : [SolverInstallPlan.showPlanIndex pkgs]---data PlanPackageProblem =-       InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc)-                                [PackageProblem]-     | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]--showPlanPackageProblem :: PlanPackageProblem -> String-showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =-     "Package " ++ prettyShow (packageId pkg)-  ++ " has an invalid configuration, in particular:\n"-  ++ unlines [ "  " ++ showPackageProblem problem-             | problem <- packageProblems ]-showPlanPackageProblem (DuplicatePackageSolverId pid dups) =-     "Package " ++ prettyShow (packageId pid) ++ " has "-  ++ show (length dups) ++ " duplicate instances."--planPackagesProblems :: Platform -> CompilerInfo-                     -> [ResolverPackage UnresolvedPkgLoc]-                     -> [PlanPackageProblem]-planPackagesProblems platform cinfo pkgs =-     [ InvalidConfiguredPackage pkg packageProblems-     | Configured pkg <- pkgs-     , let packageProblems = configuredPackageProblems platform cinfo pkg-     , not (null packageProblems) ]-  ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups-     | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]--data PackageProblem = DuplicateFlag PD.FlagName-                    | MissingFlag   PD.FlagName-                    | ExtraFlag     PD.FlagName-                    | DuplicateDeps [PackageId]-                    | MissingDep    Dependency-                    | ExtraDep      PackageId-                    | InvalidDep    Dependency PackageId--showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag flag) =-  "duplicate flag in the flag assignment: " ++ PD.unFlagName flag--showPackageProblem (MissingFlag flag) =-  "missing an assignment for the flag: " ++ PD.unFlagName flag--showPackageProblem (ExtraFlag flag) =-  "extra flag given that is not used by the package: " ++ PD.unFlagName flag--showPackageProblem (DuplicateDeps pkgids) =-     "duplicate packages specified as selected dependencies: "-  ++ intercalate ", " (map prettyShow pkgids)--showPackageProblem (MissingDep dep) =-     "the package has a dependency " ++ prettyShow dep-  ++ " but no package has been selected to satisfy it."--showPackageProblem (ExtraDep pkgid) =-     "the package configuration specifies " ++ prettyShow pkgid-  ++ " but (with the given flag assignment) the package does not actually"-  ++ " depend on any version of that package."--showPackageProblem (InvalidDep dep pkgid) =-     "the package depends on " ++ prettyShow dep-  ++ " but the configuration specifies " ++ prettyShow pkgid-  ++ " which does not satisfy the dependency."---- | A 'ConfiguredPackage' is valid if the flag assignment is total and if--- in the configuration given by the flag assignment, all the package--- dependencies are satisfied by the specified packages.----configuredPackageProblems :: Platform -> CompilerInfo-                          -> SolverPackage UnresolvedPkgLoc -> [PackageProblem]-configuredPackageProblems platform cinfo-  (SolverPackage pkg specifiedFlags stanzas specifiedDeps0  _specifiedExeDeps') =-     [ DuplicateFlag flag-     | flag <- PD.findDuplicateFlagAssignments specifiedFlags ]-  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]-  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]-  ++ [ DuplicateDeps pkgs-     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))-                                specifiedDeps1) ]-  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]-  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]-  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps-                            , not (packageSatisfiesDependency pkgid dep) ]-  -- TODO: sanity tests on executable deps-  where-    thisPkgName = packageName (srcpkgDescription pkg)--    specifiedDeps1 :: ComponentDeps [PackageId]-    specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0--    specifiedDeps :: [PackageId]-    specifiedDeps = CD.flatDeps specifiedDeps1--    mergedFlags = mergeBy compare-      (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))-      (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO--    packageSatisfiesDependency-      (PackageIdentifier name  version)-      (Dependency        name' versionRange _) = assert (name == name') $-        version `withinRange` versionRange--    dependencyName (Dependency name _ _) = name--    mergedDeps :: [MergeResult Dependency PackageId]-    mergedDeps = mergeDeps requiredDeps specifiedDeps--    mergeDeps :: [Dependency] -> [PackageId]-              -> [MergeResult Dependency PackageId]-    mergeDeps required specified =-      let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in-      mergeBy-        (\dep pkgid -> dependencyName dep `compare` packageName pkgid)-        (sortNubOn dependencyName required)-        (sortNubOn packageName    specified)--    compSpec = enableStanzas stanzas-    -- TODO: It would be nicer to use ComponentDeps here so we can be more-    -- precise in our checks. In fact, this no longer relies on buildDepends and-    -- thus should be easier to fix. As long as we _do_ use a flat list here, we-    -- have to allow for duplicates when we fold specifiedDeps; once we have-    -- proper ComponentDeps here we should get rid of the `nubOn` in-    -- `mergeDeps`.-    requiredDeps :: [Dependency]-    requiredDeps =-      --TODO: use something lower level than finalizePD-      case finalizePD specifiedFlags-         compSpec-         (const True)-         platform cinfo-         []-         (srcpkgDescription pkg) of-        Right (resolvedPkg, _) ->-            -- we filter self/internal dependencies. They are still there.-            -- This is INCORRECT.-            ---            -- If we had per-component solver, it would make this unnecessary,-            -- but no finalizePDs picks components we are not building, eg. exes.-            -- See #3775-            ---            filter ((/= thisPkgName) . dependencyName)-                (PD.enabledBuildDepends resolvedPkg compSpec)-          ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)-        Left  _ ->-          error "configuredPackageInvalidDeps internal error"----- --------------------------------------------------------------- * Simple resolver that ignores dependencies--- ---------------------------------------------------------------- | A simplistic method of resolving a list of target package names to--- available packages.------ Specifically, it does not consider package dependencies at all. Unlike--- 'resolveDependencies', no attempt is made to ensure that the selected--- packages have dependencies that are satisfiable or consistent with--- each other.------ 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'.--- It simply means preferences for installed packages will be ignored.----resolveWithoutDependencies :: DepResolverParams-                           -> Either [ResolveNoDepsError] [UnresolvedSourcePackage]-resolveWithoutDependencies (DepResolverParams targets constraints-                              prefs defpref installedPkgIndex sourcePkgIndex-                              _reorderGoals _countConflicts _fineGrained-                              _minimizeConflictSet _indGoals _avoidReinstalls-                              _shadowing _strFlags _maxBjumps _enableBj _solveExes-                              _allowBootLibInstalls _onlyConstrained _order _verbosity) =-    collectEithers $ map selectPackage (Set.toList targets)-  where-    selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage-    selectPackage pkgname-      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions-      | otherwise    = Right $! maximumBy bestByPrefs choices--      where-        -- Constraints-        requiredVersions = packageConstraints pkgname-        choices          = PackageIndex.lookupDependency sourcePkgIndex-                                                         pkgname-                                                         requiredVersions--        -- Preferences-        PackagePreferences preferredVersions preferInstalled _-          = packagePreferences pkgname--        bestByPrefs   = comparing $ \pkg ->-                          (installPref pkg, versionPref pkg, packageVersion pkg)-        installPref   = case preferInstalled of-          PreferLatest    -> const False-          PreferInstalled -> not . null-                           . InstalledPackageIndex.lookupSourcePackageId-                                                     installedPkgIndex-                           . packageId-        versionPref pkg = length . filter (packageVersion pkg `withinRange`) $-                          preferredVersions--    packageConstraints :: PackageName -> VersionRange-    packageConstraints pkgname =-      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap-    packageVersionConstraintMap =-      let pcs = map unlabelPackageConstraint constraints-      in Map.fromList [ (scopeToPackageName scope, range)-                      | PackageConstraint-                          scope (PackagePropertyVersion range) <- pcs ]--    packagePreferences :: PackageName -> PackagePreferences-    packagePreferences = interpretPackagesPreference targets defpref prefs---collectEithers :: [Either a b] -> Either [a] [b]-collectEithers = collect . partitionEithers-  where-    collect ([], xs) = Right xs-    collect (errs,_) = Left errs---- | Errors for 'resolveWithoutDependencies'.----data ResolveNoDepsError =--     -- | A package name which cannot be resolved to a specific package.-     -- Also gives the constraint on the version and whether there was-     -- a constraint on the package being installed.-     ResolveUnsatisfiable PackageName VersionRange--instance Show ResolveNoDepsError where-  show (ResolveUnsatisfiable name ver) =-       "There is no available version of " ++ prettyShow name-    ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver)
− Distribution/Client/Dependency/Types.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Dependency.Types (-    PreSolver(..),-    Solver(..),-    PackagesPreferenceDefault(..),-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Text.PrettyPrint (text)--import qualified Distribution.Compat.CharParsing as P----- | All the solvers that can be selected.-data PreSolver = AlwaysModular-  deriving (Eq, Ord, Show, Bounded, Enum, Generic)---- | All the solvers that can be used.-data Solver = Modular-  deriving (Eq, Ord, Show, Bounded, Enum, Generic)--instance Binary PreSolver-instance Binary Solver--instance Structured PreSolver-instance Structured Solver--instance Pretty PreSolver where-    pretty AlwaysModular = text "modular"--instance Parsec PreSolver where-    parsec = do-        name <- P.munch1 isAlpha-        case map toLower name of-            "modular" -> return AlwaysModular-            _         -> P.unexpected $ "PreSolver: " ++ name---- | Global policy for all packages to say if we prefer package versions that--- are already installed locally or if we just prefer the latest available.----data PackagesPreferenceDefault =--     -- | Always prefer the latest version irrespective of any existing-     -- installed version.-     ---     -- * This is the standard policy for upgrade.-     ---     PreferAllLatest--     -- | Always prefer the installed versions over ones that would need to be-     -- installed. Secondarily, prefer latest versions (eg the latest installed-     -- version or if there are none then the latest source version).-   | PreferAllInstalled--     -- | Prefer the latest version for packages that are explicitly requested-     -- but prefers the installed version for any other packages.-     ---     -- * This is the standard policy for install.-     ---   | PreferLatestForSelected-  deriving Show
− Distribution/Client/DistDirLayout.hs 
@@ -1,279 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- |------ The layout of the .\/dist\/ directory where cabal keeps all of its state--- and build artifacts.----module Distribution.Client.DistDirLayout (-    -- * 'DistDirLayout'-    DistDirLayout(..),-    DistDirParams(..),-    defaultDistDirLayout,-    ProjectRoot(..),--    -- * 'StoreDirLayout'-    StoreDirLayout(..),-    defaultStoreDirLayout,--    -- * 'CabalDirLayout'-    CabalDirLayout(..),-    mkCabalDirLayout,-    defaultCabalDirLayout-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import System.FilePath--import Distribution.Package-         ( PackageId, ComponentId, UnitId )-import Distribution.Compiler-import Distribution.Simple.Compiler-         ( PackageDB(..), PackageDBStack, OptimisationLevel(..) )-import Distribution.Types.ComponentName-import Distribution.Types.LibraryName-import Distribution.System----- | Information which can be used to construct the path to--- the build directory of a build.  This is LESS fine-grained--- than what goes into the hashed 'InstalledPackageId',--- and for good reason: we don't want this path to change if--- the user, say, adds a dependency to their project.-data DistDirParams = DistDirParams {-    distParamUnitId         :: UnitId,-    distParamPackageId      :: PackageId,-    distParamComponentId    :: ComponentId,-    distParamComponentName  :: Maybe ComponentName,-    distParamCompilerId     :: CompilerId,-    distParamPlatform       :: Platform,-    distParamOptimization   :: OptimisationLevel-    -- TODO (see #3343):-    --  Flag assignments-    --  Optimization-    }----- | The layout of the project state directory. Traditionally this has been--- called the @dist@ directory.----data DistDirLayout = DistDirLayout {--       -- | The root directory of the project. Many other files are relative to-       -- this location. In particular, the @cabal.project@ lives here.-       ---       distProjectRootDirectory     :: FilePath,--       -- | The @cabal.project@ file and related like @cabal.project.freeze@.-       -- The parameter is for the extension, like \"freeze\", or \"\" for the-       -- main file.-       ---       distProjectFile              :: String -> FilePath,--       -- | The \"dist\" directory, which is the root of where cabal keeps all-       -- its state including the build artifacts from each package we build.-       ---       distDirectory                :: FilePath,--       -- | The directory under dist where we keep the build artifacts for a-       -- package we're building from a local directory.-       ---       -- This uses a 'UnitId' not just a 'PackageName' because technically-       -- we can have multiple instances of the same package in a solution-       -- (e.g. setup deps).-       ---       distBuildDirectory           :: DistDirParams -> FilePath,-       distBuildRootDirectory       :: FilePath,--       -- | The directory under dist where we download tarballs and source-       -- control repos to.-       ---       distDownloadSrcDirectory     :: FilePath,--       -- | The directory under dist where we put the unpacked sources of-       -- packages, in those cases where it makes sense to keep the build-       -- artifacts to reduce rebuild times.-       ---       distUnpackedSrcDirectory     :: PackageId -> FilePath,-       distUnpackedSrcRootDirectory :: FilePath,--       -- | The location for project-wide cache files (e.g. state used in-       -- incremental rebuilds).-       ---       distProjectCacheFile         :: String -> FilePath,-       distProjectCacheDirectory    :: FilePath,--       -- | The location for package-specific cache files (e.g. state used in-       -- incremental rebuilds).-       ---       distPackageCacheFile         :: DistDirParams -> String -> FilePath,-       distPackageCacheDirectory    :: DistDirParams -> FilePath,--       -- | The location that sdists are placed by default.-       distSdistFile                :: PackageId -> FilePath,-       distSdistDirectory           :: FilePath,--       distTempDirectory            :: FilePath,-       distBinDirectory             :: FilePath,--       distPackageDB                :: CompilerId -> PackageDB-     }----- | The layout of a cabal nix-style store.----data StoreDirLayout = StoreDirLayout {-       storeDirectory         :: CompilerId -> FilePath,-       storePackageDirectory  :: CompilerId -> UnitId -> FilePath,-       storePackageDBPath     :: CompilerId -> FilePath,-       storePackageDB         :: CompilerId -> PackageDB,-       storePackageDBStack    :: CompilerId -> PackageDBStack,-       storeIncomingDirectory :: CompilerId -> FilePath,-       storeIncomingLock      :: CompilerId -> UnitId -> FilePath-     }-----TODO: move to another module, e.g. CabalDirLayout?--- or perhaps rename this module to DirLayouts.---- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir--- on unix, and equivalents on other systems.------ At the moment this is just a partial specification, but the idea is--- eventually to cover it all.----data CabalDirLayout = CabalDirLayout {-       cabalStoreDirLayout        :: StoreDirLayout,--       cabalLogsDirectory         :: FilePath,-       cabalWorldFile             :: FilePath-     }----- | Information about the root directory of the project.------ It can either be an implicit project root in the current dir if no--- @cabal.project@ file is found, or an explicit root if the file is found.----data ProjectRoot =-       -- | -- ^ An implicit project root. It contains the absolute project-       -- root dir.-       ProjectRootImplicit FilePath--       -- | -- ^ An explicit project root. It contains the absolute project-       -- root dir and the relative @cabal.project@ file (or explicit override)-     | ProjectRootExplicit FilePath FilePath-  deriving (Eq, Show)---- | Make the default 'DistDirLayout' based on the project root dir and--- optional overrides for the location of the @dist@ directory and the--- @cabal.project@ file.----defaultDistDirLayout :: ProjectRoot    -- ^ the project root-                     -> Maybe FilePath -- ^ the @dist@ directory or default-                                       -- (absolute or relative to the root)-                     -> DistDirLayout-defaultDistDirLayout projectRoot mdistDirectory =-    DistDirLayout {..}-  where-    (projectRootDir, projectFile) = case projectRoot of-      ProjectRootImplicit dir      -> (dir, dir </> "cabal.project")-      ProjectRootExplicit dir file -> (dir, dir </> file)--    distProjectRootDirectory = projectRootDir-    distProjectFile ext      = projectFile <.> ext--    distDirectory = distProjectRootDirectory-                </> fromMaybe "dist-newstyle" mdistDirectory-    --TODO: switch to just dist at some point, or some other new name--    distBuildRootDirectory   = distDirectory </> "build"-    distBuildDirectory params =-        distBuildRootDirectory </>-        prettyShow (distParamPlatform params) </>-        prettyShow (distParamCompilerId params) </>-        prettyShow (distParamPackageId params) </>-        (case distParamComponentName params of-            Nothing                  -> ""-            Just (CLibName LMainLibName) -> ""-            Just (CLibName (LSubLibName name)) -> "l" </> prettyShow name-            Just (CFLibName name)    -> "f" </> prettyShow name-            Just (CExeName name)     -> "x" </> prettyShow name-            Just (CTestName name)    -> "t" </> prettyShow name-            Just (CBenchName name)   -> "b" </> prettyShow name) </>-        (case distParamOptimization params of-            NoOptimisation -> "noopt"-            NormalOptimisation -> ""-            MaximumOptimisation -> "opt") </>-        (let uid_str = prettyShow (distParamUnitId params)-         in if uid_str == prettyShow (distParamComponentId params)-                then ""-                else uid_str)--    distUnpackedSrcRootDirectory   = distDirectory </> "src"-    distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory-                                      </> prettyShow pkgid-    -- we shouldn't get name clashes so this should be fine:-    distDownloadSrcDirectory       = distUnpackedSrcRootDirectory--    distProjectCacheDirectory = distDirectory </> "cache"-    distProjectCacheFile name = distProjectCacheDirectory </> name--    distPackageCacheDirectory params = distBuildDirectory params </> "cache"-    distPackageCacheFile params name = distPackageCacheDirectory params </> name--    distSdistFile pid = distSdistDirectory </> prettyShow pid <.> "tar.gz"--    distSdistDirectory = distDirectory </> "sdist"--    distTempDirectory = distDirectory </> "tmp"--    distBinDirectory = distDirectory </> "bin"--    distPackageDBPath compid = distDirectory </> "packagedb" </> prettyShow compid-    distPackageDB = SpecificPackageDB . distPackageDBPath---defaultStoreDirLayout :: FilePath -> StoreDirLayout-defaultStoreDirLayout storeRoot =-    StoreDirLayout {..}-  where-    storeDirectory compid =-      storeRoot </> prettyShow compid--    storePackageDirectory compid ipkgid =-      storeDirectory compid </> prettyShow ipkgid--    storePackageDBPath compid =-      storeDirectory compid </> "package.db"--    storePackageDB compid =-      SpecificPackageDB (storePackageDBPath compid)--    storePackageDBStack compid =-      [GlobalPackageDB, storePackageDB compid]--    storeIncomingDirectory compid =-      storeDirectory compid </> "incoming"--    storeIncomingLock compid unitid =-      storeIncomingDirectory compid </> prettyShow unitid <.> "lock"---defaultCabalDirLayout :: FilePath -> CabalDirLayout-defaultCabalDirLayout cabalDir =-    mkCabalDirLayout cabalDir Nothing Nothing--mkCabalDirLayout :: FilePath -- ^ Cabal directory-                 -> Maybe FilePath -- ^ Store directory. Must be absolute-                 -> Maybe FilePath -- ^ Log directory-                 -> CabalDirLayout-mkCabalDirLayout cabalDir mstoreDir mlogDir =-    CabalDirLayout {..}-  where-    cabalStoreDirLayout =-        defaultStoreDirLayout (fromMaybe (cabalDir </> "store") mstoreDir)-    cabalLogsDirectory = fromMaybe (cabalDir </> "logs") mlogDir-    cabalWorldFile = cabalDir </> "world"
− Distribution/Client/Exec.hs 
@@ -1,63 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Exec--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Implementation of the 'exec' command. Runs an arbitrary executable in an--- environment suitable for making use of the sandbox.--------------------------------------------------------------------------------module Distribution.Client.Exec ( exec-                                ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Simple.Compiler    (Compiler)-import Distribution.Simple.Program.Db  (ProgramDb, requireProgram, modifyProgramSearchPath)-import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation)-import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )-import Distribution.Simple.Utils       (die')--import Distribution.System    (Platform(..))---- | Execute the given command in the package's environment.------ The given command is executed with GHC configured to use the correct--- package database and with the sandbox bin directory added to the PATH.-exec :: Verbosity-     -> Compiler-     -> Platform-     -> ProgramDb-     -> [String]-     -> IO ()-exec verbosity _comp _platform programDb extraArgs =-    case extraArgs of-        (exe:args) -> do-            program <- requireProgram' verbosity programDb exe-            env <- environmentOverrides (programOverrideEnv program)-            let invocation = programInvocation-                                 program { programOverrideEnv = env }-                                 args-            runProgramInvocation verbosity invocation--        [] -> die' verbosity "Please specify an executable to run"-  where-    environmentOverrides env = return env---- | Check that a program is configured and available to be run. If--- a sandbox is available check in the sandbox's directory.-requireProgram' :: Verbosity-                -> ProgramDb-                -> String-                -> IO ConfiguredProgram-requireProgram' verbosity programDb exe = do-    (program, _) <- requireProgram-                        verbosity-                        (simpleProgram exe)-                        updateSearchPath-    return program-  where-    updateSearchPath =-        flip modifyProgramSearchPath programDb $ \searchPath -> searchPath
− Distribution/Client/Fetch.hs 
@@ -1,232 +0,0 @@-------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Fetch--- Copyright   :  (c) David Himmelstrup 2005---                    Duncan Coutts 2011--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ The cabal fetch command-------------------------------------------------------------------------------module Distribution.Client.Fetch (-    fetch,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.Types-import Distribution.Client.Targets-import Distribution.Client.FetchUtils hiding (fetchPackage)-import Distribution.Client.Dependency-import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackages, getInstalledPackages )-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan-import Distribution.Client.Setup-         ( GlobalFlags(..), FetchFlags(..), RepoContext(..) )--import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb )-import Distribution.Solver.Types.SolverPackage-import Distribution.Solver.Types.SourcePackage--import Distribution.Package-         ( packageId )-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, PackageDBStack )-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.Simple.Program-         ( ProgramDb )-import Distribution.Simple.Setup-         ( fromFlag, fromFlagOrDefault )-import Distribution.Simple.Utils-         ( die', notice, debug )-import Distribution.System-         ( Platform )---- --------------------------------------------------------------- * The fetch command--- ----------------------------------------------------------------TODO:--- * add fetch -o support--- * support tarball URLs via ad-hoc download cache (or in -o mode?)--- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied--- * Port various flags from install:---   * --updage-dependencies---   * --constraint and --preference---   * --only-dependencies, but note it conflicts with --no-deps----- | Fetch a list of packages and their dependencies.----fetch :: Verbosity-      -> PackageDBStack-      -> RepoContext-      -> Compiler-      -> Platform-      -> ProgramDb-      -> GlobalFlags-      -> FetchFlags-      -> [UserTarget]-      -> IO ()-fetch verbosity _ _ _ _ _ _ _ [] =-    notice verbosity "No packages requested. Nothing to do."--fetch verbosity packageDBs repoCtxt comp platform progdb-      globalFlags fetchFlags userTargets = do--    traverse_ (checkTarget verbosity) userTargets--    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity progdb--    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                       (fromFlag $ globalWorldFile globalFlags)-                       (packageIndex sourcePkgDb)-                       userTargets--    pkgs  <- planPackages-               verbosity comp platform fetchFlags-               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers--    pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs-    if null pkgs'-      --TODO: when we add support for remote tarballs then this message-      -- will need to be changed because for remote tarballs we fetch them-      -- at the earlier phase.-      then notice verbosity $ "No packages need to be fetched. "-                           ++ "All the requested packages are already local "-                           ++ "or cached locally."-      else if dryRun-             then notice verbosity $ unlines $-                     "The following packages would be fetched:"-                   : map (prettyShow . packageId) pkgs'--             else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs'--  where-    dryRun = fromFlag (fetchDryRun fetchFlags)--planPackages :: Verbosity-             -> Compiler-             -> Platform-             -> FetchFlags-             -> InstalledPackageIndex-             -> SourcePackageDb-             -> PkgConfigDb-             -> [PackageSpecifier UnresolvedSourcePackage]-             -> IO [UnresolvedSourcePackage]-planPackages verbosity comp platform fetchFlags-             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers--  | includeDependencies = do-      solver <- chooseSolver verbosity-                (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp)-      notice verbosity "Resolving dependencies..."-      installPlan <- foldProgress logMsg (die' verbosity) return $-                       resolveDependencies-                         platform (compilerInfo comp) pkgConfigDb-                         solver-                         resolverParams--      -- The packages we want to fetch are those packages the 'InstallPlan'-      -- that are in the 'InstallPlan.Configured' state.-      return-        [ solverPkgSource cpkg-        | (SolverInstallPlan.Configured cpkg)-            <- SolverInstallPlan.toList installPlan ]--  | otherwise =-      either (die' verbosity . unlines . map show) return $-        resolveWithoutDependencies resolverParams--  where-    resolverParams =--        setMaxBackjumps (if maxBackjumps < 0 then Nothing-                                             else Just maxBackjumps)--      . setIndependentGoals independentGoals--      . setReorderGoals reorderGoals--      . setCountConflicts countConflicts--      . setFineGrainedConflicts fineGrainedConflicts--      . setMinimizeConflictSet minimizeConflictSet--      . setShadowPkgs shadowPkgs--      . setStrongFlags strongFlags--      . setAllowBootLibInstalls allowBootLibInstalls--      . setOnlyConstrained onlyConstrained--      . setSolverVerbosity verbosity--      . addConstraints-          [ let pc = PackageConstraint-                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)-                     (PackagePropertyStanzas stanzas)-            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget-          | pkgSpecifier <- pkgSpecifiers ]--        -- Reinstall the targets given on the command line so that the dep-        -- resolver will decide that they need fetching, even if they're-        -- already installed. Since we want to get the source packages of-        -- things we might have installed (but not have the sources for).-      . reinstallTargets--      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers--    includeDependencies = fromFlag (fetchDeps fetchFlags)-    logMsg message rest = debug verbosity message >> rest--    stanzas           = [ TestStanzas | testsEnabled ]-                     ++ [ BenchStanzas | benchmarksEnabled ]-    testsEnabled      = fromFlagOrDefault False $ fetchTests fetchFlags-    benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags--    reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)-    countConflicts   = fromFlag (fetchCountConflicts   fetchFlags)-    fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags)-    minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags)-    independentGoals = fromFlag (fetchIndependentGoals fetchFlags)-    shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)-    strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)-    maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)-    allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags)-    onlyConstrained  = fromFlag (fetchOnlyConstrained  fetchFlags)---checkTarget :: Verbosity -> UserTarget -> IO ()-checkTarget verbosity target = case target of-    UserTargetRemoteTarball _uri-      -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "-            ++ "In the meantime you can use the 'unpack' commands."-    _ -> return ()--fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()-fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of-    LocalUnpackedPackage _dir  -> return ()-    LocalTarballPackage  _file -> return ()--    RemoteTarballPackage _uri _ ->-      die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "-         ++ "In the meantime you can use the 'unpack' commands."--    RemoteSourceRepoPackage _repo _ ->-      die' verbosity $ "The 'fetch' command does not yet support remote "-         ++ "source repositores."--    RepoTarballPackage repo pkgid _ -> do-      _ <- fetchRepoTarball verbosity repoCtxt repo pkgid-      return ()
− Distribution/Client/FetchUtils.hs 
@@ -1,317 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.FetchUtils--- Copyright   :  (c) David Himmelstrup 2005---                    Duncan Coutts 2011--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Functions for fetching packages-------------------------------------------------------------------------------{-# LANGUAGE RecordWildCards #-}-module Distribution.Client.FetchUtils (--    -- * fetching packages-    fetchPackage,-    isFetched,-    checkFetched,--    -- ** specifically for repo packages-    checkRepoTarballFetched,-    fetchRepoTarball,--    -- ** fetching packages asynchronously-    asyncFetchPackages,-    waitAsyncFetchPackage,-    AsyncFetchMap,--    -- * fetching other things-    downloadIndex,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.Types-import Distribution.Client.HttpUtils-         ( downloadURI, isOldHackageURI, DownloadResult(..)-         , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )--import Distribution.Package-         ( PackageId, packageName, packageVersion )-import Distribution.Simple.Utils-         ( notice, info, debug, die' )-import Distribution.Verbosity-         ( verboseUnmarkOutput )-import Distribution.Client.GlobalFlags-         ( RepoContext(..) )-import Distribution.Client.Utils-         ( ProgressPhase(..), progressMessage )--import qualified Data.Map as Map-import Control.Exception-import Control.Concurrent.Async-import Control.Concurrent.MVar-import System.Directory-         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )-import System.IO-         ( openTempFile, hClose )-import System.FilePath-         ( (</>), (<.>) )-import qualified System.FilePath.Posix as FilePath.Posix-         ( combine, joinPath )-import Network.URI-         ( URI(uriPath) )--import qualified Hackage.Security.Client as Sec---- --------------------------------------------------------------- * Actually fetch things--- ---------------------------------------------------------------- | Returns @True@ if the package has already been fetched--- or does not need fetching.----isFetched :: UnresolvedPkgLoc -> IO Bool-isFetched loc = case loc of-    LocalUnpackedPackage _dir       -> return True-    LocalTarballPackage  _file      -> return True-    RemoteTarballPackage _uri local -> return (isJust local)-    RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)-    RemoteSourceRepoPackage _ local -> return (isJust local)----- | Checks if the package has already been fetched (or does not need--- fetching) and if so returns evidence in the form of a 'PackageLocation'--- with a resolved local file location.----checkFetched :: UnresolvedPkgLoc-             -> IO (Maybe ResolvedPkgLoc)-checkFetched loc = case loc of-    LocalUnpackedPackage dir  ->-      return (Just $ LocalUnpackedPackage dir)-    LocalTarballPackage  file ->-      return (Just $ LocalTarballPackage  file)-    RemoteTarballPackage uri (Just file) ->-      return (Just $ RemoteTarballPackage uri file)-    RepoTarballPackage repo pkgid (Just file) ->-      return (Just $ RepoTarballPackage repo pkgid file)-    RemoteSourceRepoPackage repo (Just file) ->-      return (Just $ RemoteSourceRepoPackage repo file)--    RemoteTarballPackage     _uri Nothing -> return Nothing-    RemoteSourceRepoPackage _repo Nothing -> return Nothing-    RepoTarballPackage repo pkgid Nothing ->-      fmap (fmap (RepoTarballPackage repo pkgid))-           (checkRepoTarballFetched repo pkgid)---- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.----checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)-checkRepoTarballFetched repo pkgid = do-    let file = packageFile repo pkgid-    exists <- doesFileExist file-    if exists-      then return (Just file)-      else return Nothing----- | Fetch a package if we don't have it already.----fetchPackage :: Verbosity-             -> RepoContext-             -> UnresolvedPkgLoc-             -> IO ResolvedPkgLoc-fetchPackage verbosity repoCtxt loc = case loc of-    LocalUnpackedPackage dir  ->-      return (LocalUnpackedPackage dir)-    LocalTarballPackage  file ->-      return (LocalTarballPackage  file)-    RemoteTarballPackage uri (Just file) ->-      return (RemoteTarballPackage uri file)-    RepoTarballPackage repo pkgid (Just file) ->-      return (RepoTarballPackage repo pkgid file)-    RemoteSourceRepoPackage repo (Just dir) ->-      return (RemoteSourceRepoPackage repo dir)--    RemoteTarballPackage uri Nothing -> do-      path <- downloadTarballPackage uri-      return (RemoteTarballPackage uri path)-    RepoTarballPackage repo pkgid Nothing -> do-      local <- fetchRepoTarball verbosity repoCtxt repo pkgid-      return (RepoTarballPackage repo pkgid local)-    RemoteSourceRepoPackage _repo Nothing ->-      die' verbosity "fetchPackage: source repos not supported"-  where-    downloadTarballPackage uri = do-      transport <- repoContextGetTransport repoCtxt-      transportCheckHttps verbosity transport uri-      notice verbosity ("Downloading " ++ show uri)-      tmpdir <- getTemporaryDirectory-      (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"-      hClose hnd-      _ <- downloadURI transport verbosity uri path-      return path----- | Fetch a repo package if we don't have it already.----fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath-fetchRepoTarball verbosity' repoCtxt repo pkgid = do-  fetched <- doesFileExist (packageFile repo pkgid)-  if fetched-    then do info verbosity $ prettyShow pkgid ++ " has already been downloaded."-            return (packageFile repo pkgid)-    else do progressMessage verbosity ProgressDownloading (prettyShow pkgid)-            res <- downloadRepoPackage-            progressMessage verbosity ProgressDownloaded (prettyShow pkgid)-            return res-  where-    -- whether we download or not is non-deterministic-    verbosity = verboseUnmarkOutput verbosity'--    downloadRepoPackage = case repo of-      RepoLocalNoIndex{} -> return (packageFile repo pkgid)--      RepoRemote{..} -> do-        transport <- repoContextGetTransport repoCtxt-        remoteRepoCheckHttps verbosity transport repoRemote-        let uri  = packageURI  repoRemote pkgid-            dir  = packageDir  repo       pkgid-            path = packageFile repo       pkgid-        createDirectoryIfMissing True dir-        _ <- downloadURI transport verbosity uri path-        return path--      RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do-        let dir  = packageDir  repo pkgid-            path = packageFile repo pkgid-        createDirectoryIfMissing True dir-        Sec.uncheckClientErrors $ do-          info verbosity ("Writing " ++ path)-          Sec.downloadPackage' rep pkgid path-        return path---- | Downloads an index file to [config-dir/packages/serv-id] without--- hackage-security. You probably don't want to call this directly;--- use 'updateRepo' instead.----downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult-downloadIndex transport verbosity remoteRepo cacheDir = do-  remoteRepoCheckHttps verbosity transport remoteRepo-  let uri = (remoteRepoURI remoteRepo) {-              uriPath = uriPath (remoteRepoURI remoteRepo)-                          `FilePath.Posix.combine` "00-index.tar.gz"-            }-      path = cacheDir </> "00-index" <.> "tar.gz"-  createDirectoryIfMissing True cacheDir-  downloadURI transport verbosity uri path----- --------------------------------------------------------------- * Async fetch wrapper utilities--- --------------------------------------------------------------type AsyncFetchMap = Map UnresolvedPkgLoc-                         (MVar (Either SomeException ResolvedPkgLoc))---- | Fork off an async action to download the given packages (by location).------ The downloads are initiated in order, so you can arrange for packages that--- will likely be needed sooner to be earlier in the list.------ The body action is passed a map from those packages (identified by their--- location) to a completion var for that package. So the body action should--- lookup the location and use 'asyncFetchPackage' to get the result.----asyncFetchPackages :: Verbosity-                   -> RepoContext-                   -> [UnresolvedPkgLoc]-                   -> (AsyncFetchMap -> IO a)-                   -> IO a-asyncFetchPackages verbosity repoCtxt pkglocs body = do-    --TODO: [nice to have] use parallel downloads?--    asyncDownloadVars <- sequenceA-        [ do v <- newEmptyMVar-             return (pkgloc, v)-        | pkgloc <- pkglocs-        ]--    let fetchPackages :: IO ()-        fetchPackages =-          for_ asyncDownloadVars $ \(pkgloc, var) -> do-            -- Suppress marking here, because 'withAsync' means-            -- that we get nondeterministic interleaving-            result <- try $ fetchPackage (verboseUnmarkOutput verbosity)-                                repoCtxt pkgloc-            putMVar var result--    withAsync fetchPackages $ \_ ->-      body (Map.fromList asyncDownloadVars)----- | Expect to find a download in progress in the given 'AsyncFetchMap'--- and wait on it to finish.------ If the download failed with an exception then this will be thrown.------ Note: This function is supposed to be idempotent, as our install plans--- can now use the same tarball for many builds, e.g. different--- components and/or qualified goals, and these all go through the--- download phase so we end up using 'waitAsyncFetchPackage' twice on--- the same package. C.f. #4461.-waitAsyncFetchPackage :: Verbosity-                      -> AsyncFetchMap-                      -> UnresolvedPkgLoc-                      -> IO ResolvedPkgLoc-waitAsyncFetchPackage verbosity downloadMap srcloc =-    case Map.lookup srcloc downloadMap of-      Just hnd -> do-        debug verbosity $ "Waiting for download of " ++ show srcloc-        either throwIO return =<< readMVar hnd-      Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"----- --------------------------------------------------------------- * Path utilities--- ---------------------------------------------------------------- | Generate the full path to the locally cached copy of--- the tarball for a given @PackageIdentifer@.----packageFile :: Repo -> PackageId -> FilePath-packageFile repo pkgid = packageDir repo pkgid-                     </> prettyShow pkgid-                     <.> "tar.gz"---- | Generate the full path to the directory where the local cached copy of--- the tarball for a given @PackageIdentifer@ is stored.----packageDir :: Repo -> PackageId -> FilePath-packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir-packageDir repo pkgid = repoLocalDir repo-                    </> prettyShow (packageName    pkgid)-                    </> prettyShow (packageVersion pkgid)---- | Generate the URI of the tarball for a given package.----packageURI :: RemoteRepo -> PackageId -> URI-packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =-  (remoteRepoURI repo) {-    uriPath = FilePath.Posix.joinPath-      [uriPath (remoteRepoURI repo)-      ,prettyShow (packageName    pkgid)-      ,prettyShow (packageVersion pkgid)-      ,prettyShow pkgid <.> "tar.gz"]-  }-packageURI repo pkgid =-  (remoteRepoURI repo) {-    uriPath = FilePath.Posix.joinPath-      [uriPath (remoteRepoURI repo)-      ,"package"-      ,prettyShow pkgid <.> "tar.gz"]-  }
− Distribution/Client/FileMonitor.hs 
@@ -1,1130 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,-             NamedFieldPuns, BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | An abstraction to help with re-running actions when files or other--- input values they depend on have changed.----module Distribution.Client.FileMonitor (--  -- * Declaring files to monitor-  MonitorFilePath(..),-  MonitorKindFile(..),-  MonitorKindDir(..),-  FilePathGlob(..),-  monitorFile,-  monitorFileHashed,-  monitorNonExistentFile,-  monitorFileExistence,-  monitorDirectory,-  monitorNonExistentDirectory,-  monitorDirectoryExistence,-  monitorFileOrDirectory,-  monitorFileGlob,-  monitorFileGlobExistence,-  monitorFileSearchPath,-  monitorFileHashedSearchPath,--  -- * Creating and checking sets of monitored files-  FileMonitor(..),-  newFileMonitor,-  MonitorChanged(..),-  MonitorChangedReason(..),-  checkFileMonitorChanged,-  updateFileMonitor,-  MonitorTimestamp,-  beginUpdateFileMonitor,--  -- * Internal-  MonitorStateFileSet,-  MonitorStateFile,-  MonitorStateGlob,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import qualified Data.Map.Strict as Map-import qualified Data.ByteString.Lazy as BS-import qualified Data.Hashable as Hashable--import           Control.Monad-import           Control.Monad.Trans (MonadIO, liftIO)-import           Control.Monad.State (StateT, mapStateT)-import qualified Control.Monad.State as State-import           Control.Monad.Except (ExceptT, runExceptT, withExceptT,-                                       throwError)-import           Control.Exception--import           Distribution.Compat.Time-import           Distribution.Client.Glob-import           Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)-import           Distribution.Client.Utils (mergeBy, MergeResult(..))-import           Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode)-import           System.FilePath-import           System.Directory-import           System.IO----------------------------------------------------------------------------------- Types for specifying files to monitor-------- | A description of a file (or set of files) to monitor for changes.------ Where file paths are relative they are relative to a common directory--- (e.g. project root), not necessarily the process current directory.----data MonitorFilePath =-     MonitorFile {-       monitorKindFile :: !MonitorKindFile,-       monitorKindDir  :: !MonitorKindDir,-       monitorPath     :: !FilePath-     }-   | MonitorFileGlob {-       monitorKindFile :: !MonitorKindFile,-       monitorKindDir  :: !MonitorKindDir,-       monitorPathGlob :: !FilePathGlob-     }-  deriving (Eq, Show, Generic)--data MonitorKindFile = FileExists-                     | FileModTime-                     | FileHashed-                     | FileNotExists-  deriving (Eq, Show, Generic)--data MonitorKindDir  = DirExists-                     | DirModTime-                     | DirNotExists-  deriving (Eq, Show, Generic)--instance Binary MonitorFilePath-instance Binary MonitorKindFile-instance Binary MonitorKindDir--instance Structured MonitorFilePath-instance Structured MonitorKindFile-instance Structured MonitorKindDir---- | Monitor a single file for changes, based on its modification time.--- The monitored file is considered to have changed if it no longer--- exists or if its modification time has changed.----monitorFile :: FilePath -> MonitorFilePath-monitorFile = MonitorFile FileModTime DirNotExists---- | Monitor a single file for changes, based on its modification time--- and content hash. The monitored file is considered to have changed if--- it no longer exists or if its modification time and content hash have--- changed.----monitorFileHashed :: FilePath -> MonitorFilePath-monitorFileHashed = MonitorFile FileHashed DirNotExists---- | Monitor a single non-existent file for changes. The monitored file--- is considered to have changed if it exists.----monitorNonExistentFile :: FilePath -> MonitorFilePath-monitorNonExistentFile = MonitorFile FileNotExists DirNotExists---- | Monitor a single file for existence only. The monitored file is--- considered to have changed if it no longer exists.----monitorFileExistence :: FilePath -> MonitorFilePath-monitorFileExistence = MonitorFile FileExists DirNotExists---- | Monitor a single directory for changes, based on its modification--- time. The monitored directory is considered to have changed if it no--- longer exists or if its modification time has changed.----monitorDirectory :: FilePath -> MonitorFilePath-monitorDirectory = MonitorFile FileNotExists DirModTime---- | Monitor a single non-existent directory for changes.  The monitored--- directory is considered to have changed if it exists.----monitorNonExistentDirectory :: FilePath -> MonitorFilePath--- Just an alias for monitorNonExistentFile, since you can't--- tell the difference between a non-existent directory and--- a non-existent file :)-monitorNonExistentDirectory = monitorNonExistentFile---- | Monitor a single directory for existence. The monitored directory is--- considered to have changed only if it no longer exists.----monitorDirectoryExistence :: FilePath -> MonitorFilePath-monitorDirectoryExistence = MonitorFile FileNotExists DirExists---- | Monitor a single file or directory for changes, based on its modification--- time. The monitored file is considered to have changed if it no longer--- exists or if its modification time has changed.----monitorFileOrDirectory :: FilePath -> MonitorFilePath-monitorFileOrDirectory = MonitorFile FileModTime DirModTime---- | Monitor a set of files (or directories) identified by a file glob.--- The monitored glob is considered to have changed if the set of files--- matching the glob changes (i.e. creations or deletions), or for files if the--- modification time and content hash of any matching file has changed.----monitorFileGlob :: FilePathGlob -> MonitorFilePath-monitorFileGlob = MonitorFileGlob FileHashed DirExists---- | Monitor a set of files (or directories) identified by a file glob for--- existence only. The monitored glob is considered to have changed if the set--- of files matching the glob changes (i.e. creations or deletions).----monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath-monitorFileGlobExistence = MonitorFileGlob FileExists DirExists---- | Creates a list of files to monitor when you search for a file which--- unsuccessfully looked in @notFoundAtPaths@ before finding it at--- @foundAtPath@.-monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]-monitorFileSearchPath notFoundAtPaths foundAtPath =-    monitorFile foundAtPath-  : map monitorNonExistentFile notFoundAtPaths---- | Similar to 'monitorFileSearchPath', but also instructs us to--- monitor the hash of the found file.-monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]-monitorFileHashedSearchPath notFoundAtPaths foundAtPath =-    monitorFileHashed foundAtPath-  : map monitorNonExistentFile notFoundAtPaths------------------------------------------------------------------------------------ Implementation types, files status------- | The state necessary to determine whether a set of monitored--- files has changed.  It consists of two parts: a set of specific--- files to be monitored (index by their path), and a list of--- globs, which monitor may files at once.-data MonitorStateFileSet-   = MonitorStateFileSet ![MonitorStateFile]-                         ![MonitorStateGlob]-     -- Morally this is not actually a set but a bag (represented by lists).-     -- There is no principled reason to use a bag here rather than a set, but-     -- there is also no particular gain either. That said, we do preserve the-     -- order of the lists just to reduce confusion (and have predictable I/O-     -- patterns).-  deriving (Show, Generic)--instance Binary MonitorStateFileSet-instance Structured MonitorStateFileSet--type Hash = Int---- | The state necessary to determine whether a monitored file has changed.------ This covers all the cases of 'MonitorFilePath' except for globs which is--- covered separately by 'MonitorStateGlob'.------ The @Maybe ModTime@ is to cover the case where we already consider the--- file to have changed, either because it had already changed by the time we--- did the snapshot (i.e. too new, changed since start of update process) or it--- no longer exists at all.----data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir-                                         !FilePath !MonitorStateFileStatus-  deriving (Show, Generic)--data MonitorStateFileStatus-   = MonitorStateFileExists-   | MonitorStateFileModTime !ModTime        -- ^ cached file mtime-   | MonitorStateFileHashed  !ModTime !Hash  -- ^ cached mtime and content hash-   | MonitorStateDirExists-   | MonitorStateDirModTime  !ModTime        -- ^ cached dir mtime-   | MonitorStateNonExistent-   | MonitorStateAlreadyChanged-  deriving (Show, Generic)--instance Binary MonitorStateFile-instance Binary MonitorStateFileStatus-instance Structured MonitorStateFile-instance Structured MonitorStateFileStatus---- | The state necessary to determine whether the files matched by a globbing--- match have changed.----data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir-                                         !FilePathRoot !MonitorStateGlobRel-  deriving (Show, Generic)--data MonitorStateGlobRel-   = MonitorStateGlobDirs-       !Glob !FilePathGlobRel-       !ModTime-       ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted--   | MonitorStateGlobFiles-       !Glob-       !ModTime-       ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted--   | MonitorStateGlobDirTrailing-  deriving (Show, Generic)--instance Binary MonitorStateGlob-instance Binary MonitorStateGlobRel--instance Structured MonitorStateGlob-instance Structured MonitorStateGlobRel---- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by--- inspecting the state of the file system, and we can go in the reverse--- direction by just forgetting the extra info.----reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]-reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =-    map getSinglePath singlePaths- ++ map getGlobPath globPaths-  where-    getSinglePath (MonitorStateFile kindfile kinddir filepath _) =-      MonitorFile kindfile kinddir filepath--    getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =-      MonitorFileGlob kindfile kinddir $ FilePathGlob root $-        case gstate of-          MonitorStateGlobDirs  glob globs _ _ -> GlobDir  glob globs-          MonitorStateGlobFiles glob       _ _ -> GlobFile glob-          MonitorStateGlobDirTrailing          -> GlobDirTrailing----------------------------------------------------------------------------------- Checking the status of monitored files------- | A monitor for detecting changes to a set of files. It can be used to--- efficiently test if any of a set of files (specified individually or by--- glob patterns) has changed since some snapshot. In addition, it also checks--- for changes in a value (of type @a@), and when there are no changes in--- either it returns a saved value (of type @b@).------ The main use case looks like this: suppose we have some expensive action--- that depends on certain pure inputs and reads some set of files, and--- produces some pure result. We want to avoid re-running this action when it--- would produce the same result. So we need to monitor the files the action--- looked at, the other pure input values, and we need to cache the result.--- Then at some later point, if the input value didn't change, and none of the--- files changed, then we can re-use the cached result rather than re-running--- the action.------ This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance--- saves state in a disk file, so the file for that has to be specified,--- making sure it is unique. The pattern is to use 'checkFileMonitorChanged'--- to see if there's been any change. If there is, re-run the action, keeping--- track of the files, then use 'updateFileMonitor' to record the current--- set of files to monitor, the current input value for the action, and the--- result of the action.------ The typical occurrence of this pattern is captured by 'rerunIfChanged'--- and the 'Rebuild' monad. More complicated cases may need to use--- 'checkFileMonitorChanged' and 'updateFileMonitor' directly.----data FileMonitor a b-   = FileMonitor {--       -- | The file where this 'FileMonitor' should store its state.-       ---       fileMonitorCacheFile :: FilePath,--       -- | Compares a new cache key with old one to determine if a-       -- corresponding cached value is still valid.-       ---       -- Typically this is just an equality test, but in some-       -- circumstances it can make sense to do things like subset-       -- comparisons.-       ---       -- The first arg is the new value, the second is the old cached value.-       ---       fileMonitorKeyValid :: a -> a -> Bool,--       -- | When this mode is enabled, if 'checkFileMonitorChanged' returns-       -- 'MonitoredValueChanged' then we have the guarantee that no files-       -- changed, that the value change was the only change. In the default-       -- mode no such guarantee is provided which is slightly faster.-       ---       fileMonitorCheckIfOnlyValueChanged :: Bool-  }---- | Define a new file monitor.------ It's best practice to define file monitor values once, and then use the--- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this--- ensures you get the same types @a@ and @b@ for reading and writing.------ The path of the file monitor itself must be unique because it keeps state--- on disk and these would clash.----newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the-                                   -- file monitor. Must be unique.-                       -> FileMonitor a b-newFileMonitor path = FileMonitor path (==) False---- | The result of 'checkFileMonitorChanged': either the monitored files or--- value changed (and it tells us which it was) or nothing changed and we get--- the cached result.----data MonitorChanged a b =-     -- | The monitored files and value did not change. The cached result is-     -- @b@.-     ---     -- The set of monitored files is also returned. This is useful-     -- for composing or nesting 'FileMonitor's.-     MonitorUnchanged b [MonitorFilePath]--     -- | The monitor found that something changed. The reason is given.-     ---   | MonitorChanged (MonitorChangedReason a)-  deriving Show---- | What kind of change 'checkFileMonitorChanged' detected.----data MonitorChangedReason a =--     -- | One of the files changed (existence, file type, mtime or file-     -- content, depending on the 'MonitorFilePath' in question)-     MonitoredFileChanged FilePath--     -- | The pure input value changed.-     ---     -- The previous cached key value is also returned. This is sometimes-     -- useful when using a 'fileMonitorKeyValid' function that is not simply-     -- '(==)', when invalidation can be partial. In such cases it can make-     -- sense to 'updateFileMonitor' with a key value that's a combination of-     -- the new and old (e.g. set union).-   | MonitoredValueChanged a--     -- | There was no saved monitor state, cached value etc. Ie the file-     -- for the 'FileMonitor' does not exist.-   | MonitorFirstRun--     -- | There was existing state, but we could not read it. This typically-     -- happens when the code has changed compared to an existing 'FileMonitor'-     -- cache file and type of the input value or cached value has changed such-     -- that we cannot decode the values. This is completely benign as we can-     -- treat is just as if there were no cache file and re-run.-   | MonitorCorruptCache-  deriving (Eq, Show, Functor)---- | Test if the input value or files monitored by the 'FileMonitor' have--- changed. If not, return the cached value.------ See 'FileMonitor' for a full explanation.----checkFileMonitorChanged-  :: (Binary a, Structured a, Binary b, Structured b)-  => FileMonitor a b            -- ^ cache file path-  -> FilePath                   -- ^ root directory-  -> a                          -- ^ guard or key value-  -> IO (MonitorChanged a b)    -- ^ did the key or any paths change?-checkFileMonitorChanged-    monitor@FileMonitor { fileMonitorKeyValid,-                          fileMonitorCheckIfOnlyValueChanged }-    root currentKey =--    -- Consider it a change if the cache file does not exist,-    -- or we cannot decode it. Sadly ErrorCall can still happen, despite-    -- using decodeFileOrFail, e.g. Data.Char.chr errors--    handleDoesNotExist (MonitorChanged MonitorFirstRun) $-    handleErrorCall    (MonitorChanged MonitorCorruptCache) $-          readCacheFile monitor-      >>= either (\_ -> return (MonitorChanged MonitorCorruptCache))-                 checkStatusCache--  where-    checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do-        change <- checkForChanges-        case change of-          Just reason -> return (MonitorChanged reason)-          Nothing     -> return (MonitorUnchanged cachedResult monitorFiles)-            where monitorFiles = reconstructMonitorFilePaths cachedFileStatus-      where-        -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that-        -- if we return MonitoredValueChanged that only the value changed.-        -- We do that by checkin for file changes first. Otherwise it makes-        -- more sense to do the cheaper test first.-        checkForChanges-          | fileMonitorCheckIfOnlyValueChanged-          = checkFileChange cachedFileStatus cachedKey cachedResult-              `mplusMaybeT`-            checkValueChange cachedKey--          | otherwise-          = checkValueChange cachedKey-              `mplusMaybeT`-            checkFileChange cachedFileStatus cachedKey cachedResult--    mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)-    mplusMaybeT ma mb = do-      mx <- ma-      case mx of-        Nothing -> mb-        Just x  -> return (Just x)--    -- Check if the guard value has changed-    checkValueChange cachedKey-      | not (fileMonitorKeyValid currentKey cachedKey)-      = return (Just (MonitoredValueChanged cachedKey))-      | otherwise-      = return Nothing--    -- Check if any file has changed-    checkFileChange cachedFileStatus cachedKey cachedResult = do-      res <- probeFileSystem root cachedFileStatus-      case res of-        -- Some monitored file has changed-        Left changedPath ->-          return (Just (MonitoredFileChanged (normalise changedPath)))--        -- No monitored file has changed-        Right (cachedFileStatus', cacheStatus) -> do--          -- But we might still want to update the cache-          whenCacheChanged cacheStatus $-            rewriteCacheFile monitor cachedFileStatus' cachedKey cachedResult--          return Nothing---- | Helper for reading the cache file.------ This determines the type and format of the binary cache file.----readCacheFile :: (Binary a, Structured a, Binary b, Structured b)-              => FileMonitor a b-              -> IO (Either String (MonitorStateFileSet, a, b))-readCacheFile FileMonitor {fileMonitorCacheFile} =-    withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do-        contents <- BS.hGetContents hnd-        structuredDecodeOrFailIO contents---- | Helper for writing the cache file.------ This determines the type and format of the binary cache file.----rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b)-                 => FileMonitor a b-                 -> MonitorStateFileSet -> a -> b -> IO ()-rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =-    writeFileAtomic fileMonitorCacheFile $-        structuredEncode (fileset, key, result)---- | Probe the file system to see if any of the monitored files have changed.------ It returns Nothing if any file changed, or returns a possibly updated--- file 'MonitorStateFileSet' plus an indicator of whether it actually changed.------ We may need to update the cache since there may be changes in the filesystem--- state which don't change any of our affected files.------ Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a--- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run--- and find @proj2@ was created, yet contains no files matching @*.cabal@ then--- we want to update the cache despite no changes in our relevant file set.--- Specifically, we should add an mtime for this directory so we can avoid--- re-traversing the directory in future runs.----probeFileSystem :: FilePath -> MonitorStateFileSet-                -> IO (Either FilePath (MonitorStateFileSet, CacheChanged))-probeFileSystem root (MonitorStateFileSet singlePaths globPaths) =-  runChangedM $ do-    sequence_-      [ probeMonitorStateFileStatus root file status-      | MonitorStateFile _ _ file status <- singlePaths ]-    -- The glob monitors can require state changes-    globPaths' <--      sequence-        [ probeMonitorStateGlob root globPath-        | globPath <- globPaths ]-    return (MonitorStateFileSet singlePaths globPaths')----------------------------------------------------- Monad for checking for file system changes------ We need to be able to bail out if we detect a change (using ExceptT),--- but if there's no change we need to be able to rebuild the monitor--- state. And we want to optimise that rebuilding by keeping track if--- anything actually changed (using StateT), so that in the typical case--- we can avoid rewriting the state file.--newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a)-  deriving (Functor, Applicative, Monad, MonadIO)--runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged))-runChangedM (ChangedM action) =-  runExceptT $ State.runStateT action CacheUnchanged--somethingChanged :: FilePath -> ChangedM a-somethingChanged path = ChangedM $ throwError path--cacheChanged :: ChangedM ()-cacheChanged = ChangedM $ State.put CacheChanged--mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a-mapChangedFile adjust (ChangedM a) =-    ChangedM (mapStateT (withExceptT adjust) a)--data CacheChanged = CacheChanged | CacheUnchanged--whenCacheChanged :: Monad m => CacheChanged -> m () -> m ()-whenCacheChanged CacheChanged action = action-whenCacheChanged CacheUnchanged _    = return ()---------------------------- | Probe the file system to see if a single monitored file has changed.----probeMonitorStateFileStatus :: FilePath -> FilePath-                            -> MonitorStateFileStatus-                            -> ChangedM ()-probeMonitorStateFileStatus root file status =-    case status of-      MonitorStateFileExists ->-        probeFileExistence root file--      MonitorStateFileModTime mtime ->-        probeFileModificationTime root file mtime--      MonitorStateFileHashed  mtime hash ->-        probeFileModificationTimeAndHash root file mtime hash--      MonitorStateDirExists ->-        probeDirExistence root file--      MonitorStateDirModTime mtime ->-        probeFileModificationTime root file mtime--      MonitorStateNonExistent ->-        probeFileNonExistence root file--      MonitorStateAlreadyChanged ->-        somethingChanged file----- | Probe the file system to see if a monitored file glob has changed.----probeMonitorStateGlob :: FilePath      -- ^ root path-                      -> MonitorStateGlob-                      -> ChangedM MonitorStateGlob-probeMonitorStateGlob relroot-                      (MonitorStateGlob kindfile kinddir globroot glob) = do-    root <- liftIO $ getFilePathRootDirectory globroot relroot-    case globroot of-      FilePathRelative ->-        MonitorStateGlob kindfile kinddir globroot <$>-        probeMonitorStateGlobRel kindfile kinddir root "." glob--      -- for absolute cases, make the changed file we report absolute too-      _ ->-        mapChangedFile (root </>) $-        MonitorStateGlob kindfile kinddir globroot <$>-        probeMonitorStateGlobRel kindfile kinddir root "" glob--probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir-                         -> FilePath      -- ^ root path-                         -> FilePath      -- ^ path of the directory we are-                                          --   looking in relative to @root@-                         -> MonitorStateGlobRel-                         -> ChangedM MonitorStateGlobRel-probeMonitorStateGlobRel kindfile kinddir root dirName-                        (MonitorStateGlobDirs glob globPath mtime children) = do-    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime-    case change of-      Nothing -> do-        children' <- sequence-          [ do fstate' <- probeMonitorStateGlobRel-                            kindfile kinddir root-                            (dirName </> fname) fstate-               return (fname, fstate')-          | (fname, fstate) <- children ]-        return $! MonitorStateGlobDirs glob globPath mtime children'--      Just mtime' -> do-        -- directory modification time changed:-        -- a matching subdir may have been added or deleted-        matches <- filterM (\entry -> let subdir = root </> dirName </> entry-                                       in liftIO $ doesDirectoryExist subdir)-                 . filter (matchGlob glob)-               =<< liftIO (getDirectoryContents (root </> dirName))--        children' <- traverse probeMergeResult $-                          mergeBy (\(path1,_) path2 -> compare path1 path2)-                                  children-                                  (sort matches)-        return $! MonitorStateGlobDirs glob globPath mtime' children'-        -- Note that just because the directory has changed, we don't force-        -- a cache rewrite with 'cacheChanged' since that has some cost, and-        -- all we're saving is scanning the directory. But we do rebuild the-        -- cache with the new mtime', so that if the cache is rewritten for-        -- some other reason, we'll take advantage of that.--  where-    probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath-                     -> ChangedM (FilePath, MonitorStateGlobRel)--    -- Only in cached (directory deleted)-    probeMergeResult (OnlyInLeft (path, fstate)) = do-      case allMatchingFiles (dirName </> path) fstate of-        [] -> return (path, fstate)-        -- Strictly speaking we should be returning 'CacheChanged' above-        -- as we should prune the now-missing 'MonitorStateGlobRel'. However-        -- we currently just leave these now-redundant entries in the-        -- cache as they cost no IO and keeping them allows us to avoid-        -- rewriting the cache.-        (file:_) -> somethingChanged file--    -- Only in current filesystem state (directory added)-    probeMergeResult (OnlyInRight path) = do-      fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty-                           kindfile kinddir root (dirName </> path) globPath-      case allMatchingFiles (dirName </> path) fstate of-        (file:_) -> somethingChanged file-        -- This is the only case where we use 'cacheChanged' because we can-        -- have a whole new dir subtree (of unbounded size and cost), so we-        -- need to save the state of that new subtree in the cache.-        [] -> cacheChanged >> return (path, fstate)--    -- Found in path-    probeMergeResult (InBoth (path, fstate) _) = do-      fstate' <- probeMonitorStateGlobRel kindfile kinddir-                                          root (dirName </> path) fstate-      return (path, fstate')--    -- | Does a 'MonitorStateGlob' have any relevant files within it?-    allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]-    allMatchingFiles dir (MonitorStateGlobFiles _ _   entries) =-      [ dir </> fname | (fname, _) <- entries ]-    allMatchingFiles dir (MonitorStateGlobDirs  _ _ _ entries) =-      [ res-      | (subdir, fstate) <- entries-      , res <- allMatchingFiles (dir </> subdir) fstate ]-    allMatchingFiles dir MonitorStateGlobDirTrailing =-      [dir]--probeMonitorStateGlobRel _ _ root dirName-                         (MonitorStateGlobFiles glob mtime children) = do-    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime-    mtime' <- case change of-      Nothing     -> return mtime-      Just mtime' -> do-        -- directory modification time changed:-        -- a matching file may have been added or deleted-        matches <- return . filter (matchGlob glob)-               =<< liftIO (getDirectoryContents (root </> dirName))--        traverse_ probeMergeResult $-              mergeBy (\(path1,_) path2 -> compare path1 path2)-                      children-                      (sort matches)-        return mtime'--    -- Check that none of the children have changed-    for_ children $ \(file, status) ->-      probeMonitorStateFileStatus root (dirName </> file) status---    return (MonitorStateGlobFiles glob mtime' children)-    -- Again, we don't force a cache rewite with 'cacheChanged', but we do use-    -- the new mtime' if any.-  where-    probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath-                     -> ChangedM ()-    probeMergeResult mr = case mr of-      InBoth _ _            -> return ()-    -- this is just to be able to accurately report which file changed:-      OnlyInLeft  (path, _) -> somethingChanged (dirName </> path)-      OnlyInRight path      -> somethingChanged (dirName </> path)--probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =-    return MonitorStateGlobDirTrailing------------------------------------------------------------------------------------ | Update the input value and the set of files monitored by the--- 'FileMonitor', plus the cached value that may be returned in future.------ This takes a snapshot of the state of the monitored files right now, so--- 'checkFileMonitorChanged' will look for file system changes relative to--- this snapshot.------ This is typically done once the action has been completed successfully and--- we have the action's result and we know what files it looked at. See--- 'FileMonitor' for a full explanation.------ If we do take the snapshot after the action has completed then we have a--- problem. The problem is that files might have changed /while/ the action was--- running but /after/ the action read them. If we take the snapshot after the--- action completes then we will miss these changes. The solution is to record--- a timestamp before beginning execution of the action and then we make the--- conservative assumption that any file that has changed since then has--- already changed, ie the file monitor state for these files will be such that--- 'checkFileMonitorChanged' will report that they have changed.------ So if you do use 'updateFileMonitor' after the action (so you can discover--- the files used rather than predicting them in advance) then use--- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively,--- if you take the snapshot in advance of the action, or you're not monitoring--- any files then you can use @Nothing@ for the timestamp parameter.----updateFileMonitor-  :: (Binary a, Structured a, Binary b, Structured b)-  => FileMonitor a b          -- ^ cache file path-  -> FilePath                 -- ^ root directory-  -> Maybe MonitorTimestamp   -- ^ timestamp when the update action started-  -> [MonitorFilePath]        -- ^ files of interest relative to root-  -> a                        -- ^ the current key value-  -> b                        -- ^ the current result value-  -> IO ()-updateFileMonitor monitor root startTime monitorFiles-                  cachedKey cachedResult = do-    hashcache <- readCacheFileHashes monitor-    msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles-    rewriteCacheFile monitor msfs cachedKey cachedResult---- | A timestamp to help with the problem of file changes during actions.--- See 'updateFileMonitor' for details.----newtype MonitorTimestamp = MonitorTimestamp ModTime---- | Record a timestamp at the beginning of an action, and when the action--- completes call 'updateFileMonitor' passing it the timestamp.--- See 'updateFileMonitor' for details.----beginUpdateFileMonitor :: IO MonitorTimestamp-beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime---- | Take the snapshot of the monitored files. That is, given the--- specification of the set of files we need to monitor, inspect the state--- of the file system now and collect the information we'll need later to--- determine if anything has changed.----buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp-                                              -- of the start of the action-                         -> FileHashCache     -- ^ existing file hashes-                         -> FilePath          -- ^ root directory-                         -> [MonitorFilePath] -- ^ patterns of interest-                                              --   relative to root-                         -> IO MonitorStateFileSet-buildMonitorStateFileSet mstartTime hashcache root =-    go [] []-  where-    go :: [MonitorStateFile] -> [MonitorStateGlob]-       -> [MonitorFilePath] -> IO MonitorStateFileSet-    go !singlePaths !globPaths [] =-      return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths))--    go !singlePaths !globPaths-       (MonitorFile kindfile kinddir path : monitors) = do-      monitorState <- MonitorStateFile kindfile kinddir path-                  <$> buildMonitorStateFile mstartTime hashcache-                                            kindfile kinddir root path-      go (monitorState : singlePaths) globPaths monitors--    go !singlePaths !globPaths-       (MonitorFileGlob kindfile kinddir globPath : monitors) = do-      monitorState <- buildMonitorStateGlob mstartTime hashcache-                                            kindfile kinddir root globPath-      go singlePaths (monitorState : globPaths) monitors---buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update-                      -> FileHashCache          -- ^ existing file hashes-                      -> MonitorKindFile -> MonitorKindDir-                      -> FilePath               -- ^ the root directory-                      -> FilePath-                      -> IO MonitorStateFileStatus-buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do-    let abspath = root </> path-    isFile <- doesFileExist abspath-    isDir  <- doesDirectoryExist abspath-    case (isFile, kindfile, isDir, kinddir) of-      (_, FileNotExists, _, DirNotExists) ->-        -- we don't need to care if it exists now, since we check at probe time-        return MonitorStateNonExistent--      (False, _, False, _) ->-        return MonitorStateAlreadyChanged--      (True, FileExists, _, _)  ->-        return MonitorStateFileExists--      (True, FileModTime, _, _) ->-        handleIOException MonitorStateAlreadyChanged $ do-          mtime <- getModTime abspath-          if changedDuringUpdate mstartTime mtime-            then return MonitorStateAlreadyChanged-            else return (MonitorStateFileModTime mtime)--      (True, FileHashed, _, _) ->-        handleIOException MonitorStateAlreadyChanged $ do-          mtime <- getModTime abspath-          if changedDuringUpdate mstartTime mtime-            then return MonitorStateAlreadyChanged-            else do hash <- getFileHash hashcache abspath abspath mtime-                    return (MonitorStateFileHashed mtime hash)--      (_, _, True, DirExists) ->-        return MonitorStateDirExists--      (_, _, True, DirModTime) ->-        handleIOException MonitorStateAlreadyChanged $ do-          mtime <- getModTime abspath-          if changedDuringUpdate mstartTime mtime-            then return MonitorStateAlreadyChanged-            else return (MonitorStateDirModTime mtime)--      (False, _, True,  DirNotExists) -> return MonitorStateAlreadyChanged-      (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged---- | If we have a timestamp for the beginning of the update, then any file--- mtime later than this means that it changed during the update and we ought--- to consider the file as already changed.----changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool-changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime-                        = mtime > startTime-changedDuringUpdate _ _ = False---- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case--- of a file glob.------ This gets used both by 'buildMonitorStateFileSet' when we're taking the--- file system snapshot, but also by 'probeGlobStatus' as part of checking--- the monitored (globed) files for changes when we find a whole new subtree.----buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update-                      -> FileHashCache     -- ^ existing file hashes-                      -> MonitorKindFile -> MonitorKindDir-                      -> FilePath     -- ^ the root directory-                      -> FilePathGlob -- ^ the matching glob-                      -> IO MonitorStateGlob-buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot-                      (FilePathGlob globroot globPath) = do-    root <- liftIO $ getFilePathRootDirectory globroot relroot-    MonitorStateGlob kindfile kinddir globroot <$>-      buildMonitorStateGlobRel-        mstartTime hashcache kindfile kinddir root "." globPath--buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update-                         -> FileHashCache   -- ^ existing file hashes-                         -> MonitorKindFile -> MonitorKindDir-                         -> FilePath        -- ^ the root directory-                         -> FilePath        -- ^ directory we are examining-                                            --   relative to the root-                         -> FilePathGlobRel -- ^ the matching glob-                         -> IO MonitorStateGlobRel-buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root-                         dir globPath = do-    let absdir = root </> dir-    dirEntries <- getDirectoryContents absdir-    dirMTime   <- getModTime absdir-    case globPath of-      GlobDir glob globPath' -> do-        subdirs <- filterM (\subdir -> doesDirectoryExist (absdir </> subdir))-                 $ filter (matchGlob glob) dirEntries-        subdirStates <--          for (sort subdirs) $ \subdir -> do-            fstate <- buildMonitorStateGlobRel-                        mstartTime hashcache kindfile kinddir root-                        (dir </> subdir) globPath'-            return (subdir, fstate)-        return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates--      GlobFile glob -> do-        let files = filter (matchGlob glob) dirEntries-        filesStates <--          for (sort files) $ \file -> do-            fstate <- buildMonitorStateFile-                        mstartTime hashcache kindfile kinddir root-                        (dir </> file)-            return (file, fstate)-        return $! MonitorStateGlobFiles glob dirMTime filesStates--      GlobDirTrailing ->-        return MonitorStateGlobDirTrailing----- | We really want to avoid re-hashing files all the time. We already make--- the assumption that if a file mtime has not changed then we don't need to--- bother checking if the content hash has changed. We can apply the same--- assumption when updating the file monitor state. In the typical case of--- updating a file monitor the set of files is the same or largely the same so--- we can grab the previously known content hashes with their corresponding--- mtimes.----type FileHashCache = Map FilePath (ModTime, Hash)---- | We declare it a cache hit if the mtime of a file is the same as before.----lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash-lookupFileHashCache hashcache file mtime = do-    (mtime', hash) <- Map.lookup file hashcache-    guard (mtime' == mtime)-    return hash---- | Either get it from the cache or go read the file-getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash-getFileHash hashcache relfile absfile mtime =-    case lookupFileHashCache hashcache relfile mtime of-      Just hash -> return hash-      Nothing   -> readFileHash absfile---- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While--- in principle we could preserve the structure of the previous state, given--- that the set of files to monitor can change then it's simpler just to throw--- away the structure and use a finite map.----readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b)-                    => FileMonitor a b -> IO FileHashCache-readCacheFileHashes monitor =-    handleDoesNotExist Map.empty $-    handleErrorCall    Map.empty $ do-      res <- readCacheFile monitor-      case res of-        Left _             -> return Map.empty-        Right (msfs, _, _) -> return (mkFileHashCache msfs)-  where-    mkFileHashCache :: MonitorStateFileSet -> FileHashCache-    mkFileHashCache (MonitorStateFileSet singlePaths globPaths) =-                    collectAllFileHashes singlePaths-        `Map.union` collectAllGlobHashes globPaths--    collectAllFileHashes singlePaths =-      Map.fromList [ (fpath, (mtime, hash))-                   | MonitorStateFile _ _ fpath-                       (MonitorStateFileHashed mtime hash) <- singlePaths ]--    collectAllGlobHashes globPaths =-      Map.fromList [ (fpath, (mtime, hash))-                   | MonitorStateGlob _ _ _ gstate <- globPaths-                   , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]--    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =-      [ res-      | (subdir, fstate) <- entries-      , res <- collectGlobHashes (dir </> subdir) fstate ]--    collectGlobHashes dir (MonitorStateGlobFiles  _ _ entries) =-      [ (dir </> fname, (mtime, hash))-      | (fname, MonitorStateFileHashed mtime hash) <- entries ]--    collectGlobHashes _dir MonitorStateGlobDirTrailing =-      []------------------------------------------------------------------------------------ Utils------- | Within the @root@ directory, check if @file@ has its 'ModTime' is--- the same as @mtime@, short-circuiting if it is different.-probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM ()-probeFileModificationTime root file mtime = do-    unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime-    unless unchanged (somethingChanged file)---- | Within the @root@ directory, check if @file@ has its 'ModTime' and--- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is--- different.-probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash-                                 -> ChangedM ()-probeFileModificationTimeAndHash root file mtime hash = do-    unchanged <- liftIO $-      checkFileModificationTimeAndHashUnchanged root file mtime hash-    unless unchanged (somethingChanged file)---- | Within the @root@ directory, check if @file@ still exists as a file.--- If it *does not* exist, short-circuit.-probeFileExistence :: FilePath -> FilePath -> ChangedM ()-probeFileExistence root file = do-    existsFile <- liftIO $ doesFileExist (root </> file)-    unless existsFile (somethingChanged file)---- | Within the @root@ directory, check if @dir@ still exists.--- If it *does not* exist, short-circuit.-probeDirExistence :: FilePath -> FilePath -> ChangedM ()-probeDirExistence root dir = do-    existsDir  <- liftIO $ doesDirectoryExist (root </> dir)-    unless existsDir (somethingChanged dir)---- | Within the @root@ directory, check if @file@ still does not exist.--- If it *does* exist, short-circuit.-probeFileNonExistence :: FilePath -> FilePath -> ChangedM ()-probeFileNonExistence root file = do-    existsFile <- liftIO $ doesFileExist (root </> file)-    existsDir  <- liftIO $ doesDirectoryExist (root </> file)-    when (existsFile || existsDir) (somethingChanged file)---- | Returns @True@ if, inside the @root@ directory, @file@ has the same--- 'ModTime' as @mtime@.-checkModificationTimeUnchanged :: FilePath -> FilePath-                               -> ModTime -> IO Bool-checkModificationTimeUnchanged root file mtime =-  handleIOException False $ do-    mtime' <- getModTime (root </> file)-    return (mtime == mtime')---- | Returns @True@ if, inside the @root@ directory, @file@ has the--- same 'ModTime' and 'Hash' as @mtime and @chash@.-checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath-                                          -> ModTime -> Hash -> IO Bool-checkFileModificationTimeAndHashUnchanged root file mtime chash =-  handleIOException False $ do-    mtime' <- getModTime (root </> file)-    if mtime == mtime'-      then return True-      else do-        chash' <- readFileHash (root </> file)-        return (chash == chash')---- | Read a non-cryptographic hash of a @file@.-readFileHash :: FilePath -> IO Hash-readFileHash file =-    withBinaryFile file ReadMode $ \hnd ->-      evaluate . Hashable.hash =<< BS.hGetContents hnd---- | Given a directory @dir@, return @Nothing@ if its 'ModTime'--- is the same as @mtime@, and the new 'ModTime' if it is not.-checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime)-checkDirectoryModificationTime dir mtime =-  handleIOException Nothing $ do-    mtime' <- getModTime dir-    if mtime == mtime'-      then return Nothing-      else return (Just mtime')---- | Run an IO computation, returning the first argument @e@ if there is an 'error'--- call. ('ErrorCall')-handleErrorCall :: a -> IO a -> IO a-handleErrorCall e = handle handler where-#if MIN_VERSION_base(4,9,0)-    handler (ErrorCallWithLocation _ _) = return e-#else-    handler (ErrorCall _) = return e-#endif----- | Run an IO computation, returning @e@ if there is any 'IOException'.------ This policy is OK in the file monitor code because it just causes the--- monitor to report that something changed, and then code reacting to that--- will normally encounter the same IO exception when it re-runs the action--- that uses the file.----handleIOException :: a -> IO a -> IO a-handleIOException e =-    handle (anyIOException e)-  where-    anyIOException :: a -> IOException -> IO a-    anyIOException x _ = return x------------------------------------------------------------------------------------ Instances----
− Distribution/Client/Freeze.hs 
@@ -1,266 +0,0 @@--------------------------------------------------------------------------------- |--- 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, getFreezePkgs-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.Config ( SavedConfig(..) )-import Distribution.Client.Types-import Distribution.Client.Targets-import Distribution.Client.Dependency-import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackages, getInstalledPackages )-import Distribution.Client.SolverInstallPlan-         ( SolverInstallPlan, SolverPlanPackage )-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan-import Distribution.Client.Setup-         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)-         , RepoContext(..) )-import Distribution.Client.Sandbox.PackageEnvironment-         ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,-           userPackageEnvironmentFile )--import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PkgConfigDb-import Distribution.Solver.Types.SolverId--import Distribution.Package-         ( Package, packageId, packageName, packageVersion )-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, PackageDBStack )-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.Simple.Program-         ( ProgramDb )-import Distribution.Simple.Setup-         ( fromFlag, fromFlagOrDefault, flagToMaybe )-import Distribution.Simple.Utils-         ( die', notice, debug, writeFileAtomic, toUTF8LBS)-import Distribution.System-         ( Platform )--import Distribution.Version-         ( thisVersion )---- --------------------------------------------------------------- * The freeze command--- ---------------------------------------------------------------- | Freeze all of the dependencies by writing a constraints section--- constraining each dependency to an exact version.----freeze :: Verbosity-       -> PackageDBStack-       -> RepoContext-       -> Compiler-       -> Platform-       -> ProgramDb-       -> GlobalFlags-       -> FreezeFlags-       -> IO ()-freeze verbosity packageDBs repoCtxt comp platform progdb-      globalFlags freezeFlags = do--    pkgs  <- getFreezePkgs-               verbosity packageDBs repoCtxt comp platform progdb-               globalFlags freezeFlags--    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 globalFlags pkgs--  where-    dryRun = fromFlag (freezeDryRun freezeFlags)---- | Get the list of packages whose versions would be frozen by the @freeze@--- command.-getFreezePkgs :: Verbosity-              -> PackageDBStack-              -> RepoContext-              -> Compiler-              -> Platform-              -> ProgramDb-              -> GlobalFlags-              -> FreezeFlags-              -> IO [SolverPlanPackage]-getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb-      globalFlags freezeFlags = do--    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt-    pkgConfigDb       <- readPkgConfigDb      verbosity progdb--    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                       (fromFlag $ globalWorldFile globalFlags)-                       (packageIndex sourcePkgDb)-                       [UserTargetLocalDir "."]--    sanityCheck pkgSpecifiers-    planPackages-               verbosity comp platform freezeFlags-               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers-  where-    sanityCheck pkgSpecifiers = do-      when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $-        die' verbosity $ "internal error: 'resolveUserTargets' returned "-           ++ "unexpected named package specifiers!"-      when (length pkgSpecifiers /= 1) $-        die' verbosity $ "internal error: 'resolveUserTargets' returned "-           ++ "unexpected source package specifiers!"--planPackages :: Verbosity-             -> Compiler-             -> Platform-             -> FreezeFlags-             -> InstalledPackageIndex-             -> SourcePackageDb-             -> PkgConfigDb-             -> [PackageSpecifier UnresolvedSourcePackage]-             -> IO [SolverPlanPackage]-planPackages verbosity comp platform freezeFlags-             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do--  solver <- chooseSolver verbosity-            (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)-  notice verbosity "Resolving dependencies..."--  installPlan <- foldProgress logMsg (die' verbosity) return $-                   resolveDependencies-                     platform (compilerInfo comp) pkgConfigDb-                     solver-                     resolverParams--  return $ pruneInstallPlan installPlan pkgSpecifiers--  where-    resolverParams =--        setMaxBackjumps (if maxBackjumps < 0 then Nothing-                                             else Just maxBackjumps)--      . setIndependentGoals independentGoals--      . setReorderGoals reorderGoals--      . setCountConflicts countConflicts--      . setFineGrainedConflicts fineGrainedConflicts--      . setMinimizeConflictSet minimizeConflictSet--      . setShadowPkgs shadowPkgs--      . setStrongFlags strongFlags--      . setAllowBootLibInstalls allowBootLibInstalls--      . setOnlyConstrained onlyConstrained--      . setSolverVerbosity verbosity--      . addConstraints-          [ let pkg = pkgSpecifierTarget pkgSpecifier-                pc = PackageConstraint (scopeToplevel pkg)-                                       (PackagePropertyStanzas stanzas)-            in LabeledPackageConstraint pc ConstraintSourceFreeze-          | pkgSpecifier <- pkgSpecifiers ]--      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers--    logMsg message rest = debug verbosity message >> rest--    stanzas = [ TestStanzas | testsEnabled ]-           ++ [ BenchStanzas | benchmarksEnabled ]-    testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags-    benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags--    reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)-    countConflicts   = fromFlag (freezeCountConflicts   freezeFlags)-    fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags)-    minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags)-    independentGoals = fromFlag (freezeIndependentGoals freezeFlags)-    shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)-    strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)-    maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)-    allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)-    onlyConstrained  = fromFlag (freezeOnlyConstrained  freezeFlags)----- | Remove all unneeded packages from an install plan.------ A package is unneeded if it is either------ 1) the package that we are freezing, or------ 2) not a dependency (directly or transitively) of the package we are---    freezing.  This is useful for removing previously installed packages---    which are no longer required from the install plan.------ Invariant: @pkgSpecifiers@ must refer to packages which are not--- 'PreExisting' in the 'SolverInstallPlan'.-pruneInstallPlan :: SolverInstallPlan-                 -> [PackageSpecifier UnresolvedSourcePackage]-                 -> [SolverPlanPackage]-pruneInstallPlan installPlan pkgSpecifiers =-    removeSelf pkgIds $-    SolverInstallPlan.dependencyClosure installPlan pkgIds-  where-    pkgIds = [ PlannedId (packageId pkg)-             | SpecificSourcePackage pkg <- pkgSpecifiers ]-    removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)-    removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "-                         ++ "unexpected package specifiers!"---freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()-freezePackages verbosity globalFlags pkgs = do--    pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $-                   loadUserConfig verbosity ""-                   (flagToMaybe . globalConstraintsFile $ globalFlags)-    writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv-  where-    addFrozenConstraints config =-        config {-            savedConfigureExFlags = (savedConfigureExFlags config) {-                configExConstraints = map constraint pkgs-            }-        }-    constraint pkg =-        (pkgIdToConstraint $ packageId pkg-        ,ConstraintSourceUserConfig userPackageEnvironmentFile)-      where-        pkgIdToConstraint pkgId =-            UserConstraint (UserQualified UserQualToplevel (packageName pkgId))-                           (PackagePropertyVersion $ thisVersion (packageVersion pkgId))-    createPkgEnv config = mempty { pkgEnvSavedConfig = config }-    showPkgEnv = toUTF8LBS . showPackageEnvironment---formatPkgs :: Package pkg => [pkg] -> [String]-formatPkgs = map $ showPkg . packageId-  where-    showPkg pid = name pid ++ " == " ++ version pid-    name = prettyShow . packageName-    version = prettyShow . packageVersion
− Distribution/Client/GZipUtils.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.GZipUtils--- Copyright   :  (c) Dmitry Astapov 2010--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Provides a convenience functions for working with files that may or may not--- be zipped.-------------------------------------------------------------------------------module Distribution.Client.GZipUtils (-    maybeDecompress,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Codec.Compression.Zlib.Internal-import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk))--#ifndef MIN_VERSION_zlib-#define MIN_VERSION_zlib(x,y,z) 1-#endif--#if MIN_VERSION_zlib(0,6,0)-import Control.Exception (throw)-import Control.Monad.ST.Lazy (ST, runST)-import qualified Data.ByteString as Strict-#endif---- | Attempts to decompress the `bytes' under the assumption that--- "data format" error at the very beginning of the stream means--- that it is already decompressed. Caller should make sanity checks--- to verify that it is not, in fact, garbage.------ This is to deal with http proxies that lie to us and transparently--- decompress without removing the content-encoding header. See:--- <https://github.com/haskell/cabal/issues/678>----maybeDecompress :: ByteString -> ByteString-#if MIN_VERSION_zlib(0,6,0)-maybeDecompress bytes = runST (go bytes decompressor)-  where-    decompressor :: DecompressStream (ST s)-    decompressor = decompressST gzipOrZlibFormat defaultDecompressParams--    -- DataError at the beginning of the stream probably means that stream is-    -- not compressed, so we return it as-is.-    -- TODO: alternatively, we might consider looking for the two magic bytes-    -- at the beginning of the gzip header.  (not an option for zlib, though.)-    go :: Monad m => ByteString -> DecompressStream m -> m ByteString-    go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k-    go _  (DecompressStreamEnd       _bs ) = return Empty-    go _  (DecompressStreamError _err    ) = return bytes-    go cs (DecompressInputRequired      k) = go cs' =<< k c-      where-        (c, cs') = uncons cs--    -- Once we have received any output though we regard errors as actual errors-    -- and we throw them (as pure exceptions).-    -- TODO: We could (and should) avoid these pure exceptions.-    go' :: Monad m => ByteString -> DecompressStream m -> m ByteString-    go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k-    go' _  (DecompressStreamEnd       _bs ) = return Empty-    go' _  (DecompressStreamError err     ) = throw err-    go' cs (DecompressInputRequired      k) = go' cs' =<< k c-      where-        (c, cs') = uncons cs--    uncons :: ByteString -> (Strict.ByteString, ByteString)-    uncons Empty        = (Strict.empty, Empty)-    uncons (Chunk c cs) = (c, cs)-#else-maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes-  where-    -- DataError at the beginning of the stream probably means that stream is not compressed.-    -- Returning it as-is.-    -- TODO: alternatively, we might consider looking for the two magic bytes-    -- at the beginning of the gzip header.-    foldStream (StreamError _ _) = bytes-    foldStream somethingElse = doFold somethingElse--    doFold StreamEnd               = BS.Empty-    doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)-    doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg-#endif
− Distribution/Client/GenBounds.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.GenBounds--- Copyright   :  (c) Doug Beardsley 2015--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ The cabal gen-bounds command for generating PVP-compliant version bounds.-------------------------------------------------------------------------------module Distribution.Client.GenBounds (-    genBounds-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Distribution.Utils.Generic (safeLast)--import Distribution.Client.Init-         ( incVersion )-import Distribution.Client.Freeze-         ( getFreezePkgs )-import Distribution.Client.Setup-         ( GlobalFlags(..), FreezeFlags(..), RepoContext )-import Distribution.Package-         ( Package(..), unPackageName, packageName, packageVersion )-import Distribution.PackageDescription-         ( enabledBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePD )-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription )-import Distribution.Types.ComponentRequestedSpec-         ( defaultComponentRequestedSpec )-import Distribution.Types.Dependency-import Distribution.Simple.Compiler-         ( Compiler, PackageDBStack, compilerInfo )-import Distribution.Simple.Program-         ( ProgramDb )-import Distribution.Simple.Utils-         ( tryFindPackageDesc )-import Distribution.System-         ( Platform )-import Distribution.Version-         ( Version, alterVersion-         , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals-         , orLaterVersion, earlierVersion, intersectVersionRanges )-import System.Directory-         ( getCurrentDirectory )---- | Does this version range have an upper bound?-hasUpperBound :: VersionRange -> Bool-hasUpperBound vr =-    case safeLast (asVersionIntervals vr) of-      Nothing -> False-      Just l  -> if snd l == NoUpperBound then False else True---- | Given a version, return an API-compatible (according to PVP) version range.------ Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.------ This version is slightly different than the one in--- 'Distribution.Client.Init'.  This one uses a.b.c as the lower bound because--- the user could be using a new function introduced in a.b.c which would make--- ">= a.b" incorrect.-pvpize :: Version -> VersionRange-pvpize v = orLaterVersion (vn 3)-           `intersectVersionRanges`-           earlierVersion (incVersion 1 (vn 2))-  where-    vn n = alterVersion (take n) v---- | Show the PVP-mandated version range for this package. The @padTo@ parameter--- specifies the width of the package name column.-showBounds :: Package pkg => Int -> pkg -> String-showBounds padTo p = unwords $-    (padAfter padTo $ unPackageName $ packageName p) :-    map showInterval (asVersionIntervals $ pvpize $ packageVersion p)-  where-    padAfter :: Int -> String -> String-    padAfter n str = str ++ replicate (n - length str) ' '--    showInterval :: (LowerBound, UpperBound) -> String-    showInterval (LowerBound _ _, NoUpperBound) =-      error "Error: expected upper bound...this should never happen!"-    showInterval (LowerBound l _, UpperBound u _) =-      unwords [">=", prettyShow l, "&& <", prettyShow u]---- | Entry point for the @gen-bounds@ command.-genBounds-    :: Verbosity-    -> PackageDBStack-    -> RepoContext-    -> Compiler-    -> Platform-    -> ProgramDb-    -> GlobalFlags-    -> FreezeFlags-    -> IO ()-genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do -    let cinfo = compilerInfo comp--    cwd <- getCurrentDirectory-    path <- tryFindPackageDesc verbosity cwd-    gpd <- readGenericPackageDescription verbosity path-    -- NB: We don't enable tests or benchmarks, since often they-    -- don't really have useful bounds.-    let epd = finalizePD mempty defaultComponentRequestedSpec-                    (const True) platform cinfo [] gpd-    case epd of-      Left _ -> putStrLn "finalizePD failed"-      Right (pd,_) -> do-        let needBounds = filter (not . hasUpperBound . depVersion) $-                         enabledBuildDepends pd defaultComponentRequestedSpec--        if (null needBounds)-          then putStrLn-               "Congratulations, all your dependencies have upper bounds!"-          else go needBounds-  where-     go needBounds = do-       pkgs  <- getFreezePkgs-                  verbosity packageDBs repoCtxt comp platform progdb-                  globalFlags freezeFlags--       putStrLn boundsNeededMsg--       let isNeeded pkg = unPackageName (packageName pkg)-                          `elem` map depName needBounds-       let thePkgs = filter isNeeded pkgs--       let padTo = maximum $ map (length . unPackageName . packageName) pkgs-       traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs--     depName :: Dependency -> String-     depName (Dependency pn _ _) = unPackageName pn--     depVersion :: Dependency -> VersionRange-     depVersion (Dependency _ vr _) = vr---- | The message printed when some dependencies are found to be lacking proper--- PVP-mandated bounds.-boundsNeededMsg :: String-boundsNeededMsg = unlines-  [ ""-  , "The following packages need bounds and here is a suggested starting point."-  , "You can copy and paste this into the build-depends section in your .cabal"-  , "file and it should work (with the appropriate removal of commas)."-  , ""-  , "Note that version bounds are a statement that you've successfully built and"-  , "tested your package and expect it to work with any of the specified package"-  , "versions (PROVIDED that those packages continue to conform with the PVP)."-  , "Therefore, the version bounds generated here are the most conservative"-  , "based on the versions that you are currently building with.  If you know"-  , "your package will work with versions outside the ranges generated here,"-  , "feel free to widen them."-  , ""-  ]
− Distribution/Client/Get.hs 
@@ -1,333 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Get--- Copyright   :  (c) Andrea Vezzosi 2008---                    Duncan Coutts 2011---                    John Millikin 2012--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'cabal get' command.--------------------------------------------------------------------------------module Distribution.Client.Get (-    get,--    -- * Cloning 'SourceRepo's-    -- | Mainly exported for testing purposes-    clonePackagesFromSourceRepo,-    ClonePackageException(..),-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (get)-import Distribution.Compat.Directory-         ( listDirectory )-import Distribution.Package-         ( PackageId, packageId, packageName )-import Distribution.Simple.Setup-         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )-import Distribution.Simple.Utils-         ( notice, die', info, writeFileAtomic )-import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Program-         ( programName )-import Distribution.Types.SourceRepo (RepoKind (..))-import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)--import Distribution.Client.Setup-         ( GlobalFlags(..), GetFlags(..), RepoContext(..) )-import Distribution.Client.Types-import Distribution.Client.Targets-import Distribution.Client.Dependency-import Distribution.Client.VCS-import Distribution.Client.FetchUtils-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)-import Distribution.Client.IndexUtils-        ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos )-import Distribution.Solver.Types.SourcePackage--import qualified Data.Map as Map-import System.Directory-         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )-import System.FilePath-         ( (</>), (<.>), addTrailingPathSeparator )----- | Entry point for the 'cabal get' command.-get :: Verbosity-    -> RepoContext-    -> GlobalFlags-    -> GetFlags-    -> [UserTarget]-    -> IO ()-get verbosity _ _ _ [] =-    notice verbosity "No packages requested. Nothing to do."--get verbosity repoCtxt globalFlags getFlags userTargets = do-  let useSourceRepo = case getSourceRepository getFlags of-                        NoFlag -> False-                        _      -> True--  unless useSourceRepo $-    traverse_ (checkTarget verbosity) userTargets--  let idxState :: Maybe TotalIndexState-      idxState = flagToMaybe $ getIndexState getFlags--      activeRepos :: Maybe ActiveRepos-      activeRepos = flagToMaybe $ getActiveRepos getFlags--  (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos--  pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                   (fromFlag $ globalWorldFile globalFlags)-                   (packageIndex sourcePkgDb)-                   userTargets--  pkgs <- either (die' verbosity . unlines . map show) return $-            resolveWithoutDependencies-              (resolverParams sourcePkgDb pkgSpecifiers)--  unless (null prefix) $-    createDirectoryIfMissing True prefix--  if useSourceRepo-    then clone  pkgs-    else unpack pkgs--  where-    resolverParams sourcePkgDb pkgSpecifiers =-        --TODO: add command-line constraint and preference args for unpack-        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers--    prefix = fromFlagOrDefault "" (getDestDir getFlags)--    clone :: [UnresolvedSourcePackage] -> IO ()-    clone = clonePackagesFromSourceRepo verbosity prefix kind-          . map (\pkg -> (packageId pkg, packageSourceRepos pkg))-      where-        kind = fromFlag . getSourceRepository $ getFlags-        packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]-        packageSourceRepos = PD.sourceRepos-                           . PD.packageDescription-                           . srcpkgDescription--    unpack :: [UnresolvedSourcePackage] -> IO ()-    unpack pkgs = do-      for_ pkgs $ \pkg -> do-        location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg)-        let pkgid = packageId pkg-            descOverride | usePristine = Nothing-                         | otherwise   = srcpkgDescrOverride pkg-        case location of-          LocalTarballPackage tarballPath ->-            unpackPackage verbosity prefix pkgid descOverride tarballPath--          RemoteTarballPackage _tarballURL tarballPath ->-            unpackPackage verbosity prefix pkgid descOverride tarballPath--          RepoTarballPackage _repo _pkgid tarballPath ->-            unpackPackage verbosity prefix pkgid descOverride tarballPath--          RemoteSourceRepoPackage _repo _ ->-            die' verbosity $ "The 'get' command does no yet support targets "-                          ++ "that are remote source repositories."--          LocalUnpackedPackage _ ->-            error "Distribution.Client.Get.unpack: the impossible happened."-      where-        usePristine = fromFlagOrDefault False (getPristine getFlags)--checkTarget :: Verbosity -> UserTarget -> IO ()-checkTarget verbosity target = case target of-    UserTargetLocalDir       dir  -> die' verbosity (notTarball dir)-    UserTargetLocalCabalFile file -> die' verbosity (notTarball file)-    _                             -> return ()-  where-    notTarball t =-        "The 'get' command is for tarball packages. "-     ++ "The target '" ++ t ++ "' is not a tarball."---- --------------------------------------------------------------- * Unpacking the source tarball--- --------------------------------------------------------------unpackPackage :: Verbosity -> FilePath -> PackageId-              -> PackageDescriptionOverride-              -> FilePath  -> IO ()-unpackPackage verbosity prefix pkgid descOverride pkgPath = do-    let pkgdirname               = prettyShow pkgid-        pkgdir                   = prefix </> pkgdirname-        pkgdir'                  = addTrailingPathSeparator pkgdir-        emptyDirectory directory = null <$> listDirectory directory-    existsDir  <- doesDirectoryExist pkgdir-    when existsDir $ do-      isEmpty <- emptyDirectory pkgdir-      unless isEmpty $-        die' verbosity $-        "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking."-    existsFile  <- doesFileExist pkgdir-    when existsFile $ die' verbosity $-     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."-    notice verbosity $ "Unpacking to " ++ pkgdir'-    Tar.extractTarGzFile prefix pkgdirname pkgPath--    case descOverride of-      Nothing     -> return ()-      Just pkgtxt -> do-        let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"-        info verbosity $-          "Updating " ++ descFilePath-                      ++ " with the latest revision from the index."-        writeFileAtomic descFilePath pkgtxt----- --------------------------------------------------------------- * Cloning packages from their declared source repositories--- ---------------------------------------------------------------data ClonePackageException =-       ClonePackageNoSourceRepos       PackageId-     | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)-     | ClonePackageNoRepoType          PackageId PD.SourceRepo-     | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType-     | ClonePackageNoRepoLocation      PackageId PD.SourceRepo-     | ClonePackageDestinationExists   PackageId FilePath Bool-     | ClonePackageFailedWithExitCode  PackageId SourceRepoProxy String ExitCode-  deriving (Show, Eq)--instance Exception ClonePackageException where-  displayException (ClonePackageNoSourceRepos pkgid) =-       "Cannot fetch a source repository for package " ++ prettyShow pkgid-    ++ ". The package does not specify any source repositories."--  displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =-       "Cannot fetch a source repository for package " ++ prettyShow pkgid-    ++ ". The package does not specify a source repository of the requested "-    ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind--  displayException (ClonePackageNoRepoType pkgid _repo) =-       "Cannot fetch the source repository for package " ++ prettyShow pkgid-    ++ ". The package's description specifies a source repository but does "-    ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."--  displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =-       "Cannot fetch the source repository for package " ++ prettyShow pkgid-    ++ ". The repository type '" ++ prettyShow repoType-    ++ "' is not yet supported."--  displayException (ClonePackageNoRepoLocation pkgid _repo) =-       "Cannot fetch the source repository for package " ++ prettyShow pkgid-    ++ ". The package's description specifies a source repository but does "-    ++ "not specify the repository 'location' field (i.e. the URL)."--  displayException (ClonePackageDestinationExists pkgid dest isdir) =-       "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "-    ++ if isdir then "The destination directory " ++ dest ++ " already exists."-                else "A file " ++ dest ++ " is in the way."--  displayException (ClonePackageFailedWithExitCode-                      pkgid repo vcsprogname exitcode) =-       "Failed to fetch the source repository for package " ++ prettyShow pkgid-    ++ ", repository location " ++ srpLocation repo ++ " ("-    ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."----- | Given a bunch of package ids and their corresponding available--- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into--- new subdirs of the given directory.----clonePackagesFromSourceRepo :: Verbosity-                            -> FilePath            -- ^ destination dir prefix-                            -> Maybe RepoKind      -- ^ preferred 'RepoKind'-                            -> [(PackageId, [PD.SourceRepo])]-                                                   -- ^ the packages and their-                                                   -- available 'SourceRepo's-                            -> IO ()-clonePackagesFromSourceRepo verbosity destDirPrefix-                            preferredRepoKind pkgrepos = do--    -- Do a bunch of checks and collect the required info-    pkgrepos' <- traverse preCloneChecks pkgrepos--    -- Configure the VCS drivers for all the repository types we may need-    vcss <- configureVCSs verbosity $-              Map.fromList [ (vcsRepoType vcs, vcs)-                           | (_, _, vcs, _) <- pkgrepos' ]--    -- Now execute all the required commands for each repo-    sequence_-      [ cloneSourceRepo verbosity vcs' repo destDir-          `catch` \exitcode ->-           throwIO (ClonePackageFailedWithExitCode-                      pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)-      | (pkgid, repo, vcs, destDir) <- pkgrepos'-      , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss-      ]--  where-    preCloneChecks :: (PackageId, [PD.SourceRepo])-                   -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)-    preCloneChecks (pkgid, repos) = do-      repo <- case selectPackageSourceRepo preferredRepoKind repos of-        Just repo            -> return repo-        Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)-        Nothing              -> throwIO (ClonePackageNoSourceReposOfKind-                                           pkgid preferredRepoKind)--      (repo', vcs) <- case validatePDSourceRepo repo of-        Right (repo', _, _, vcs) -> return (repo', vcs)-        Left SourceRepoRepoTypeUnspecified ->-          throwIO (ClonePackageNoRepoType pkgid repo)--        Left (SourceRepoRepoTypeUnsupported repo' repoType) ->-          throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)--        Left SourceRepoLocationUnspecified ->-          throwIO (ClonePackageNoRepoLocation pkgid repo)--      let destDir = destDirPrefix </> prettyShow (packageName pkgid)-      destDirExists  <- doesDirectoryExist destDir-      destFileExists <- doesFileExist      destDir-      when (destDirExists || destFileExists) $-        throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)--      return (pkgid, repo', vcs, destDir)------------------------------------------------------------------------------------ Selecting------------------------------------------------------------------------------------ | Pick the 'SourceRepo' to use to get the package sources from.------ Note that this does /not/ depend on what 'VCS' drivers we are able to--- successfully configure. It is based only on the 'SourceRepo's declared--- in the package, and optionally on a preferred 'RepoKind'.----selectPackageSourceRepo :: Maybe RepoKind-                        -> [PD.SourceRepo]-                        -> Maybe PD.SourceRepo-selectPackageSourceRepo preferredRepoKind =-    listToMaybe-    -- Sort repositories by kind, from This to Head to Unknown. Repositories-    -- with equivalent kinds are selected based on the order they appear in-    -- the Cabal description file.-  . sortBy (comparing thisFirst)-    -- If the user has specified the repo kind, filter out the repositories-    -- they're not interested in.-  . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)-  where-    thisFirst :: PD.SourceRepo -> Int-    thisFirst r = case PD.repoKind r of-        RepoThis -> 0-        RepoHead -> case PD.repoTag r of-            -- If the type is 'head' but the author specified a tag, they-            -- probably meant to create a 'this' repository but screwed up.-            Just _  -> 0-            Nothing -> 1-        RepoKindUnknown _ -> 2
− Distribution/Client/Glob.hs 
@@ -1,244 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}----TODO: [code cleanup] plausibly much of this module should be merged with--- similar functionality in Cabal.-module Distribution.Client.Glob-    ( FilePathGlob(..)-    , FilePathRoot(..)-    , FilePathGlobRel(..)-    , Glob-    , GlobPiece(..)-    , matchFileGlob-    , matchFileGlobRel-    , matchGlob-    , isTrivialFilePathGlob-    , getFilePathRootDirectory-    ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Data.List        (stripPrefix)-import System.Directory-import System.FilePath--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp----- | A file path specified by globbing----data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel-  deriving (Eq, Show, Generic)--data FilePathGlobRel-   = GlobDir  !Glob !FilePathGlobRel-   | GlobFile !Glob-   | GlobDirTrailing                -- ^ trailing dir, a glob ending in @/@-  deriving (Eq, Show, Generic)---- | A single directory or file component of a globbed path-type Glob = [GlobPiece]---- | A piece of a globbing pattern-data GlobPiece = WildCard-               | Literal String-               | Union [Glob]-  deriving (Eq, Show, Generic)--data FilePathRoot-   = FilePathRelative-   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'-   | FilePathHomeDir-  deriving (Eq, Show, Generic)--instance Binary FilePathGlob-instance Binary FilePathRoot-instance Binary FilePathGlobRel-instance Binary GlobPiece--instance Structured FilePathGlob-instance Structured FilePathRoot-instance Structured FilePathGlobRel-instance Structured GlobPiece---- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and--- is in fact equivalent to a non-glob 'FilePath'.------ If it is trivial in this sense then the result is the equivalent constant--- 'FilePath'. On the other hand if it is not trivial (so could in principle--- match more than one file) then the result is @Nothing@.----isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath-isTrivialFilePathGlob (FilePathGlob root pathglob) =-    case root of-      FilePathRelative       -> go []      pathglob-      FilePathRoot root'     -> go [root'] pathglob-      FilePathHomeDir        -> Nothing-  where-    go paths (GlobDir  [Literal path] globs) = go (path:paths) globs-    go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))-    go paths  GlobDirTrailing          = Just (addTrailingPathSeparator-                                                 (joinPath (reverse paths)))-    go _ _ = Nothing---- | Get the 'FilePath' corresponding to a 'FilePathRoot'.------ The 'FilePath' argument is required to supply the path for the--- 'FilePathRelative' case.----getFilePathRootDirectory :: FilePathRoot-                         -> FilePath      -- ^ root for relative paths-                         -> IO FilePath-getFilePathRootDirectory  FilePathRelative   root = return root-getFilePathRootDirectory (FilePathRoot root) _    = return root-getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory------------------------------------------------------------------------------------ Matching------- | Match a 'FilePathGlob' against the file system, starting from a given--- root directory for relative paths. The results of relative globs are--- relative to the given root. Matches for absolute globs are absolute.----matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]-matchFileGlob relroot (FilePathGlob globroot glob) = do-    root <- getFilePathRootDirectory globroot relroot-    matches <- matchFileGlobRel root glob-    case globroot of-      FilePathRelative -> return matches-      _                -> return (map (root </>) matches)---- | Match a 'FilePathGlobRel' against the file system, starting from a--- given root directory. The results are all relative to the given root.----matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]-matchFileGlobRel root glob0 = go glob0 ""-  where-    go (GlobFile glob) dir = do-      entries <- getDirectoryContents (root </> dir)-      let files = filter (matchGlob glob) entries-      return (map (dir </>) files)--    go (GlobDir glob globPath) dir = do-      entries <- getDirectoryContents (root </> dir)-      subdirs <- filterM (\subdir -> doesDirectoryExist-                                       (root </> dir </> subdir))-               $ filter (matchGlob glob) entries-      concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs--    go GlobDirTrailing dir = return [dir]----- | Match a globbing pattern against a file path component----matchGlob :: Glob -> String -> Bool-matchGlob = goStart-  where-    -- From the man page, glob(7):-    --   "If a filename starts with a '.', this character must be-    --    matched explicitly."--    go, goStart :: [GlobPiece] -> String -> Bool--    goStart (WildCard:_) ('.':_)  = False-    goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)-                                        globs-    goStart rest               cs = go rest cs--    go []                 ""    = True-    go (Literal lit:rest) cs-      | Just cs' <- stripPrefix lit cs-                                = go rest cs'-      | otherwise               = False-    go [WildCard]         ""    = True-    go (WildCard:rest)   (c:cs) = go rest (c:cs) || go (WildCard:rest) cs-    go (Union globs:rest)   cs  = any (\glob -> go (glob ++ rest) cs) globs-    go []                (_:_)  = False-    go (_:_)              ""    = False------------------------------------------------------------------------------------ Parsing & printing-----instance Pretty FilePathGlob where-  pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob--instance Parsec FilePathGlob where-    parsec = do-        root <- parsec-        case root of-            FilePathRelative -> FilePathGlob root <$> parsec-            _                -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)--instance Pretty FilePathRoot where-    pretty  FilePathRelative    = Disp.empty-    pretty (FilePathRoot root)  = Disp.text root-    pretty FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'--instance Parsec FilePathRoot where-    parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where-        root = FilePathRoot "/" <$ P.char '/'-        home = FilePathHomeDir <$ P.string "~/"-        drive = do-            dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')-            _ <- P.char ':'-            _ <- P.char '/' <|> P.char '\\'-            return (FilePathRoot (toUpper dr : ":\\"))--instance Pretty FilePathGlobRel where-    pretty (GlobDir  glob pathglob) = dispGlob glob-                            Disp.<> Disp.char '/'-                            Disp.<> pretty pathglob-    pretty (GlobFile glob)          = dispGlob glob-    pretty GlobDirTrailing          = Disp.empty--instance Parsec FilePathGlobRel where-    parsec = parsecPath where-        parsecPath :: CabalParsing m => m FilePathGlobRel-        parsecPath = do-            glob <- parsecGlob-            dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)--        dirSep :: CabalParsing m => m ()-        dirSep = () <$ P.char '/' <|> P.try (do-            _ <- P.char '\\'-            -- check this isn't an escape code-            P.notFollowedBy (P.satisfy isGlobEscapedChar))--dispGlob :: Glob -> Disp.Doc-dispGlob = Disp.hcat . map dispPiece-  where-    dispPiece WildCard      = Disp.char '*'-    dispPiece (Literal str) = Disp.text (escape str)-    dispPiece (Union globs) = Disp.braces-                                (Disp.hcat (Disp.punctuate-                                             (Disp.char ',')-                                             (map dispGlob globs)))-    escape []               = []-    escape (c:cs)-      | isGlobEscapedChar c = '\\' : c : escape cs-      | otherwise           =        c : escape cs--parsecGlob :: CabalParsing m => m Glob-parsecGlob = some parsecPiece where-    parsecPiece = P.choice [ literal, wildcard, union ]--    wildcard = WildCard <$ P.char '*'-    union    = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))-    literal  = Literal <$> some litchar--    litchar = normal <|> escape--    normal  = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')-    escape  = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar--isGlobEscapedChar :: Char -> Bool-isGlobEscapedChar '*'  = True-isGlobEscapedChar '{'  = True-isGlobEscapedChar '}'  = True-isGlobEscapedChar ','  = True-isGlobEscapedChar _    = False
− Distribution/Client/GlobalFlags.hs 
@@ -1,295 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}--module Distribution.Client.GlobalFlags (-    GlobalFlags(..)-  , defaultGlobalFlags-  , RepoContext(..)-  , withRepoContext-  , withRepoContext'-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.Types-         ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey )-import Distribution.Simple.Setup-         ( Flag(..), fromFlag, flagToMaybe )-import Distribution.Utils.NubList-         ( NubList, fromNubList )-import Distribution.Client.HttpUtils-         ( HttpTransport, configureTransport )-import Distribution.Simple.Utils-         ( info, warn )--import Distribution.Client.IndexUtils.ActiveRepos-         ( ActiveRepos )--import Control.Concurrent-         ( MVar, newMVar, modifyMVar )-import System.FilePath-         ( (</>) )-import Network.URI-         ( URI, uriScheme, uriPath )-import qualified Data.Map as Map--import qualified Hackage.Security.Client                    as Sec-import qualified Hackage.Security.Util.Path                 as Sec-import qualified Hackage.Security.Util.Pretty               as Sec-import qualified Hackage.Security.Client.Repository.Cache   as Sec-import qualified Hackage.Security.Client.Repository.Local   as Sec.Local-import qualified Hackage.Security.Client.Repository.Remote  as Sec.Remote-import qualified Distribution.Client.Security.HTTP          as Sec.HTTP-import qualified Distribution.Client.Security.DNS           as Sec.DNS--import qualified System.FilePath.Posix as FilePath.Posix---- --------------------------------------------------------------- * Global flags--- ---------------------------------------------------------------- | Flags that apply at the top level, not to any sub-command.--data GlobalFlags = GlobalFlags-    { globalVersion           :: Flag Bool-    , globalNumericVersion    :: Flag Bool-    , globalConfigFile        :: Flag FilePath-    , globalConstraintsFile   :: Flag FilePath-    , globalRemoteRepos       :: NubList RemoteRepo     -- ^ Available Hackage servers.-    , globalCacheDir          :: Flag FilePath-    , globalLocalNoIndexRepos :: NubList LocalRepo-    , globalActiveRepos       :: Flag ActiveRepos-    , globalLogsDir           :: Flag FilePath-    , globalWorldFile         :: Flag FilePath-    , globalIgnoreExpiry      :: Flag Bool    -- ^ Ignore security expiry dates-    , globalHttpTransport     :: Flag String-    , globalNix               :: Flag Bool  -- ^ Integrate with Nix-    , globalStoreDir          :: Flag FilePath-    , globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)-    } deriving Generic--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags-    { globalVersion           = Flag False-    , globalNumericVersion    = Flag False-    , globalConfigFile        = mempty-    , globalConstraintsFile   = mempty-    , globalRemoteRepos       = mempty-    , globalCacheDir          = mempty-    , globalLocalNoIndexRepos = mempty-    , globalActiveRepos       = mempty-    , globalLogsDir           = mempty-    , globalWorldFile         = mempty-    , globalIgnoreExpiry      = Flag False-    , globalHttpTransport     = mempty-    , globalNix               = Flag False-    , globalStoreDir          = mempty-    , globalProgPathExtra     = mempty-    }--instance Monoid GlobalFlags where-    mempty = gmempty-    mappend = (<>)--instance Semigroup GlobalFlags where-    (<>) = gmappend---- --------------------------------------------------------------- * Repo context--- ---------------------------------------------------------------- | Access to repositories-data RepoContext = RepoContext {-    -- | All user-specified repositories-    repoContextRepos :: [Repo]--    -- | Get the HTTP transport-    ---    -- The transport will be initialized on the first call to this function.-    ---    -- NOTE: It is important that we don't eagerly initialize the transport.-    -- Initializing the transport is not free, and especially in contexts where-    -- we don't know a-priori whether or not we need the transport (for instance-    -- when using cabal in "nix mode") incurring the overhead of transport-    -- initialization on _every_ invocation (eg @cabal build@) is undesirable.-  , repoContextGetTransport :: IO HttpTransport--    -- | Get the (initialized) secure repo-    ---    -- (the 'Repo' type itself is stateless and must remain so, because it-    -- must be serializable)-  , repoContextWithSecureRepo :: forall a.-                                 Repo-                              -> (forall down. Sec.Repository down -> IO a)-                              -> IO a--    -- | Should we ignore expiry times (when checking security)?-  , repoContextIgnoreExpiry :: Bool-  }---- | Wrapper around 'Repository', hiding the type argument-data SecureRepo = forall down. SecureRepo (Sec.Repository down)--withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a-withRepoContext verbosity globalFlags =-    withRepoContext'-      verbosity-      (fromNubList (globalRemoteRepos       globalFlags))-      (fromNubList (globalLocalNoIndexRepos globalFlags))-      (fromFlag    (globalCacheDir          globalFlags))-      (flagToMaybe (globalHttpTransport     globalFlags))-      (flagToMaybe (globalIgnoreExpiry      globalFlags))-      (fromNubList (globalProgPathExtra     globalFlags))--withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo]-                 -> FilePath  -> Maybe String -> Maybe Bool-                 -> [FilePath]-                 -> (RepoContext -> IO a)-                 -> IO a-withRepoContext' verbosity remoteRepos localNoIndexRepos-                 sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do-    for_ localNoIndexRepos $ \local ->-        unless (FilePath.Posix.isAbsolute (localRepoPath local)) $-            warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"--    transportRef <- newMVar Nothing-    let httpLib = Sec.HTTP.transportAdapter-                    verbosity-                    (getTransport transportRef)-    initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->-      callback RepoContext {-          repoContextRepos          = allRemoteRepos-                                   ++ allLocalNoIndexRepos-        , repoContextGetTransport   = getTransport transportRef-        , repoContextWithSecureRepo = withSecureRepo secureRepos'-        , repoContextIgnoreExpiry   = fromMaybe False ignoreExpiry-        }-  where-    secureRemoteRepos =-      [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ]--    allRemoteRepos :: [Repo]-    allRemoteRepos =-      [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir-      | remote <- remoteRepos-      , let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)-            isSecure = remoteRepoSecure remote == Just True-      ]--    allLocalNoIndexRepos :: [Repo]-    allLocalNoIndexRepos =-      [ RepoLocalNoIndex local cacheDir-      | local <- localNoIndexRepos-      , let cacheDir | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local-                     | otherwise                  = localRepoPath local-      ]--    getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport-    getTransport transportRef =-      modifyMVar transportRef $ \mTransport -> do-        transport <- case mTransport of-          Just tr -> return tr-          Nothing -> configureTransport verbosity extraPaths httpTransport-        return (Just transport, transport)--    withSecureRepo :: Map Repo SecureRepo-                   -> Repo-                   -> (forall down. Sec.Repository down -> IO a)-                   -> IO a-    withSecureRepo secureRepos repo callback =-      case Map.lookup repo secureRepos of-        Just (SecureRepo secureRepo) -> callback secureRepo-        Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"---- | Initialize the provided secure repositories------ Assumed invariant: `remoteRepoSecure` should be set for all these repos.-initSecureRepos :: forall a. Verbosity-                -> Sec.HTTP.HttpLib-                -> [(RemoteRepo, FilePath)]-                -> (Map Repo SecureRepo -> IO a)-                -> IO a-initSecureRepos verbosity httpLib repos callback = go Map.empty repos-  where-    go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a-    go !acc [] = callback acc-    go !acc ((r,cacheDir):rs) = do-      cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir-      initSecureRepo verbosity httpLib r cachePath $ \r' ->-        go (Map.insert (RepoSecure r cacheDir) r' acc) rs---- | Initialize the given secure repo------ The security library has its own concept of a "local" repository, distinct--- from @cabal-install@'s; these are secure repositories, but live in the local--- file system. We use the convention that these repositories are identified by--- URLs of the form @file:/path/to/local/repo@.-initSecureRepo :: Verbosity-               -> Sec.HTTP.HttpLib-               -> RemoteRepo  -- ^ Secure repo ('remoteRepoSecure' assumed)-               -> Sec.Path Sec.Absolute -- ^ Cache dir-               -> (SecureRepo -> IO a)  -- ^ Callback-               -> IO a-initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do-    requiresBootstrap <- withRepo [] Sec.requiresBootstrap--    mirrors <- if requiresBootstrap-               then do-                   info verbosity $ "Trying to locate mirrors via DNS for " ++-                                    "initial bootstrap of secure " ++-                                    "repository '" ++ show remoteRepoURI ++-                                    "' ..."--                   Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI-               else pure []--    withRepo mirrors $ \r -> do-      when requiresBootstrap $ Sec.uncheckClientErrors $-        Sec.bootstrap r-          (map Sec.KeyId    remoteRepoRootKeys)-          (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))-      callback $ SecureRepo r-  where-    -- Initialize local or remote repo depending on the URI-    withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a-    withRepo _ callback | uriScheme remoteRepoURI == "file:" = do-      dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)-      Sec.Local.withRepository dir-                               cache-                               Sec.hackageRepoLayout-                               Sec.hackageIndexLayout-                               logTUF-                               callback-    withRepo mirrors callback =-      Sec.Remote.withRepository httpLib-                                (remoteRepoURI:mirrors)-                                Sec.Remote.defaultRepoOpts-                                cache-                                Sec.hackageRepoLayout-                                Sec.hackageIndexLayout-                                logTUF-                                callback--    cache :: Sec.Cache-    cache = Sec.Cache {-        cacheRoot   = cachePath-      , cacheLayout = Sec.cabalCacheLayout {-            Sec.cacheLayoutIndexTar   = cacheFn "01-index.tar"-          , Sec.cacheLayoutIndexIdx   = cacheFn "01-index.tar.idx"-          , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz"-          }-      }--    cacheFn :: FilePath -> Sec.CachePath-    cacheFn = Sec.rootPath . Sec.fragment--    -- We display any TUF progress only in verbose mode, including any transient-    -- verification errors. If verification fails, then the final exception that-    -- is thrown will of course be shown.-    logTUF :: Sec.LogMessage -> IO ()-    logTUF = info verbosity . Sec.pretty
− Distribution/Client/Haddock.hs 
@@ -1,70 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Haddock--- Copyright   :  (c) Andrea Vezzosi 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Interfacing with Haddock----------------------------------------------------------------------------------module Distribution.Client.Haddock-    (-     regenerateHaddockIndex-    )-    where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Data.List (maximumBy)-import System.Directory (createDirectoryIfMissing, renameFile)-import System.FilePath ((</>), splitFileName)-import Distribution.Package-         ( packageVersion )-import Distribution.Simple.Haddock (haddockPackagePaths)-import Distribution.Simple.Program (haddockProgram, ProgramDb-                                   , runProgram, requireProgramVersion)-import Distribution.Version (mkVersion, orLaterVersion)-import Distribution.Simple.PackageIndex-         ( InstalledPackageIndex, allPackagesByName )-import Distribution.Simple.Utils-         ( debug, installDirectoryContents, withTempDirectory )-import Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo(exposed) )--regenerateHaddockIndex :: Verbosity-                       -> InstalledPackageIndex -> ProgramDb-                       -> FilePath-                       -> IO ()-regenerateHaddockIndex verbosity pkgs progdb index = do-      (paths, warns) <- haddockPackagePaths pkgs' Nothing-      let paths' = [ (interface, html) | (interface, Just html, _) <- paths]-      for_ warns (debug verbosity)--      (confHaddock, _, _) <--          requireProgramVersion verbosity haddockProgram-                                    (orLaterVersion (mkVersion [0,6])) progdb--      createDirectoryIfMissing True destDir--      withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do--        let flags = [ "--gen-contents"-                    , "--gen-index"-                    , "--odir=" ++ tempDir-                    , "--title=Haskell modules on this system" ]-                 ++ [ "--read-interface=" ++ html ++ "," ++ interface-                    | (interface, html) <- paths' ]-        runProgram verbosity confHaddock flags-        renameFile (tempDir </> "index.html") (tempDir </> destFile)-        installDirectoryContents verbosity tempDir destDir--  where-    (destDir,destFile) = splitFileName index-    pkgs' = [ maximumBy (comparing packageVersion) pkgvers'-            | (_pname, pkgvers) <- allPackagesByName pkgs-            , let pkgvers' = filter exposed pkgvers-            , not (null pkgvers') ]
− Distribution/Client/HashValue.hs 
@@ -1,90 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-module Distribution.Client.HashValue (-    HashValue,-    hashValue,-    truncateHash,-    showHashValue,-    readFileHashValue,-    hashFromTUF,-    ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Hackage.Security.Client as Sec--import qualified Crypto.Hash.SHA256         as SHA256-import qualified Data.ByteString.Base16     as Base16-import qualified Data.ByteString.Char8      as BS-import qualified Data.ByteString.Lazy.Char8 as LBS--import System.IO         (IOMode (..), withBinaryFile)---------------------------------------------------- The specific choice of hash implementation------- Is a crypto hash necessary here? One thing to consider is who controls the--- inputs and what's the result of a hash collision. Obviously we should not--- install packages we don't trust because they can run all sorts of code, but--- if I've checked there's no TH, no custom Setup etc, is there still a--- problem? If someone provided us a tarball that hashed to the same value as--- some other package and we installed it, we could end up re-using that--- installed package in place of another one we wanted. So yes, in general--- there is some value in preventing intentional hash collisions in installed--- package ids.--newtype HashValue = HashValue BS.ByteString-  deriving (Eq, Generic, Show, Typeable)---- Cannot do any sensible validation here. Although we use SHA256--- for stuff we hash ourselves, we can also get hashes from TUF--- and that can in principle use different hash functions in future.------ Therefore, we simply derive this structurally.-instance Binary HashValue-instance Structured HashValue---- | Hash some data. Currently uses SHA256.----hashValue :: LBS.ByteString -> HashValue-hashValue = HashValue . SHA256.hashlazy--showHashValue :: HashValue -> String-showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)---- | Hash the content of a file. Uses SHA256.----readFileHashValue :: FilePath -> IO HashValue-readFileHashValue tarball =-    withBinaryFile tarball ReadMode $ \hnd ->-      evaluate . hashValue =<< LBS.hGetContents hnd---- | Convert a hash from TUF metadata into a 'PackageSourceHash'.------ Note that TUF hashes don't neessarily have to be SHA256, since it can--- support new algorithms in future.----hashFromTUF :: Sec.Hash -> HashValue-hashFromTUF (Sec.Hash hashstr) =-    --TODO: [code cleanup] either we should get TUF to use raw bytestrings or-    -- perhaps we should also just use a base16 string as the internal rep.-    case Base16.decode (BS.pack hashstr) of-#if MIN_VERSION_base16_bytestring(1,0,0)-      Right hash -> HashValue hash-      Left _ -> error "hashFromTUF: cannot decode base16"-#else-      (hash, trailing) | not (BS.null hash) && BS.null trailing-        -> HashValue hash-      _ -> error "hashFromTUF: cannot decode base16 hash"-#endif---- | Truncate a 32 byte SHA256 hash to------ For example 20 bytes render as 40 hex chars, which we use for unit-ids.--- Or even 4 bytes for 'hashedInstalledPackageIdShort'----truncateHash :: Int -> HashValue -> HashValue-truncateHash n (HashValue h) = HashValue (BS.take n h)
− Distribution/Client/HttpUtils.hs 
@@ -1,916 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP          #-}--------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists.-------------------------------------------------------------------------------module Distribution.Client.HttpUtils (-    DownloadResult(..),-    configureTransport,-    HttpTransport(..),-    HttpCode,-    downloadURI,-    transportCheckHttps,-    remoteRepoCheckHttps,-    remoteRepoTryUpgradeToHttps,-    isOldHackageURI-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (Proxy (..))-import Distribution.Utils.Generic--import Network.HTTP-         ( Request (..), Response (..), RequestMethod (..)-         , Header(..), HeaderName(..), lookupHeader )-import Network.HTTP.Proxy ( Proxy(..), fetchProxy)-import Network.URI-         ( URI (..), URIAuth (..), uriToString )-import Network.Browser-         ( browse, setOutHandler, setErrHandler, setProxy-         , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )-import qualified Control.Exception as Exception-import Distribution.Simple.Utils-         ( die', info, warn, debug, notice-         , copyFileVerbose,  withTempFile, IOData (..) )-import Distribution.Client.Utils-         ( withTempFileName, cabalInstallVersion )-import Distribution.Client.Types-         ( unRepoName, RemoteRepo(..) )-import Distribution.System-         ( buildOS, buildArch )-import qualified System.FilePath.Posix as FilePath.Posix-         ( splitDirectories )-import System.FilePath-         ( (<.>), takeFileName, takeDirectory )-import System.Directory-         ( doesFileExist, renameFile, canonicalizePath )-import System.IO-         ( withFile, IOMode(ReadMode), hGetContents, hClose )-import System.IO.Error-         ( isDoesNotExistError )-import Distribution.Simple.Program-         ( Program, simpleProgram, ConfiguredProgram, programPath-         , ProgramInvocation(..), programInvocation-         , ProgramSearchPathEntry(..)-         , getProgramInvocationOutput )-import Distribution.Simple.Program.Db-         ( ProgramDb, emptyProgramDb, addKnownPrograms-         , configureAllKnownPrograms-         , requireProgram, lookupProgram-         , modifyProgramSearchPath )-import Distribution.Simple.Program.Run-         ( getProgramInvocationOutputAndErrors )-import Numeric (showHex)-import System.Random (randomRIO)--import qualified Crypto.Hash.SHA256         as SHA256-import qualified Data.ByteString.Base16     as Base16-import qualified Distribution.Compat.CharParsing as P-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Char8      as BS8-import qualified Data.ByteString.Lazy       as LBS-import qualified Data.ByteString.Lazy.Char8 as LBS8----------------------------------------------------------------------------------- Downloading a URI, given an HttpTransport-----data DownloadResult = FileAlreadyInCache-                    | FileDownloaded FilePath-  deriving (Eq)--data DownloadCheck-    = Downloaded                           -- ^ already downloaded and sha256 matches-    | CheckETag String                     -- ^ already downloaded and we have etag-    | NeedsDownload (Maybe BS.ByteString)  -- ^ needs download with optional hash check-  deriving Eq--downloadURI :: HttpTransport-            -> Verbosity-            -> URI      -- ^ What to download-            -> FilePath -- ^ Where to put it-            -> IO DownloadResult-downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do-  copyFileVerbose verbosity (uriPath uri) path-  return (FileDownloaded path)-  -- Can we store the hash of the file so we can safely return path when the-  -- hash matches to avoid unnecessary computation?--downloadURI transport verbosity uri path = do--    targetExists <- doesFileExist path--    downloadCheck <--      -- if we have uriFrag, then we expect there to be #sha256=...-      if not (null uriFrag)-      then case sha256parsed of-        -- we know the hash, and target exists-        Right expected | targetExists -> do-          contents <- LBS.readFile path-          let actual = SHA256.hashlazy contents-          if expected == actual-          then return Downloaded-          else return (NeedsDownload (Just expected))--        -- we known the hash, target doesn't exist-        Right expected -> return (NeedsDownload (Just expected))--        -- we failed to parse uriFragment-        Left err -> die' verbosity $-          "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err--      -- if there are no uri fragment, use ETag-      else do-        etagPathExists <- doesFileExist etagPath-        -- In rare cases the target file doesn't exist, but the etag does.-        if targetExists && etagPathExists-        then return (CheckETag etagPath)-        else return (NeedsDownload Nothing)--    -- Only use the external http transports if we actually have to-    -- (or have been told to do so)-    let transport'-          | uriScheme uri == "http:"-          , not (transportManuallySelected transport)-          = plainHttpTransport--          | otherwise-          = transport--    case downloadCheck of-      Downloaded         -> return FileAlreadyInCache-      CheckETag etag     -> makeDownload transport' Nothing (Just etag)-      NeedsDownload hash -> makeDownload transport' hash Nothing--  where-    makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do-      result <- getHttp transport' verbosity uri etag tmpFile []--      -- Only write the etag if we get a 200 response code.-      -- A 304 still sends us an etag header.-      case result of-        -- if we have hash, we don't care about etag.-        (200, _) | Just expected <- sha256 -> do-          contents <- LBS.readFile tmpFile-          let actual = SHA256.hashlazy contents-          unless (actual == expected) $-            die' verbosity $ unwords-              [ "Failed to download", show uri-              , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected)-              , "actual:", BS8.unpack (Base16.encode actual)-              ]--        (200, Just newEtag) -> writeFile etagPath newEtag-        _ -> return ()--      case fst result of-        200 -> do-            info verbosity ("Downloaded to " ++ path)-            renameFile tmpFile path-            return (FileDownloaded path)-        304 -> do-            notice verbosity "Skipping download: local and remote files match."-            return FileAlreadyInCache-        errCode ->  die' verbosity $ "failed to download " ++ show uri-                       ++ " : HTTP code " ++ show errCode--    etagPath = path <.> "etag"-    uriFrag = uriFragment uri--    sha256parsed :: Either String BS.ByteString-    sha256parsed = explicitEitherParsec fragmentParser uriFrag--    fragmentParser = do-        _ <- P.string "#sha256="-        str <- some P.hexDigit-        let bs = Base16.decode (BS8.pack str)-#if MIN_VERSION_base16_bytestring(1,0,0)-        either fail return bs-#else-        return (fst bs)-#endif----------------------------------------------------------------------------------- Utilities for repo url management-----remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()-remoteRepoCheckHttps verbosity transport repo-  | uriScheme (remoteRepoURI repo) == "https:"-  , not (transportSupportsHttps transport)-  = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)-    ++ "' specifies a URL that " ++ requiresHttpsErrorMessage-  | otherwise = return ()--transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()-transportCheckHttps verbosity transport uri-  | uriScheme uri == "https:"-  , not (transportSupportsHttps transport)-              = die' verbosity $ "The URL " ++ show uri-                   ++ " " ++ requiresHttpsErrorMessage-  | otherwise = return ()--requiresHttpsErrorMessage :: String-requiresHttpsErrorMessage =-      "requires HTTPS however the built-in HTTP implementation "-   ++ "does not support HTTPS. The transport implementations with HTTPS "-   ++ "support are " ++ intercalate ", "-      [ name | (name, _, True, _ ) <- supportedTransports ]-   ++ ". One of these will be selected automatically if the corresponding "-   ++ "external program is available, or one can be selected specifically "-   ++ "with the global flag --http-transport="--remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo-remoteRepoTryUpgradeToHttps verbosity transport repo-  | remoteRepoShouldTryHttps repo-  , uriScheme (remoteRepoURI repo) == "http:"-  , not (transportSupportsHttps transport)-  , not (transportManuallySelected transport)-  = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using "-       ++ "HTTPS for authenticated uploads is recommended. "-       ++ "The transport implementations with HTTPS support are "-       ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]-       ++ "but they require the corresponding external program to be "-       ++ "available. You can either make one available or use plain HTTP by "-       ++ "using the global flag --http-transport=plain-http (or putting the "-       ++ "equivalent in the config file). With plain HTTP, your password "-       ++ "is sent using HTTP digest authentication so it cannot be easily "-       ++ "intercepted, but it is not as secure as using HTTPS."--  | remoteRepoShouldTryHttps repo-  , uriScheme (remoteRepoURI repo) == "http:"-  , transportSupportsHttps transport-  = return repo {-      remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }-    }--  | otherwise-  = return repo---- | Utility function for legacy support.-isOldHackageURI :: URI -> Bool-isOldHackageURI uri-    = case uriAuthority uri of-        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->-            FilePath.Posix.splitDirectories (uriPath uri)-            == ["/","packages","archive"]-        _ -> False------------------------------------------------------------------------------------ Setting up a HttpTransport-----data HttpTransport = HttpTransport {-      -- | GET a URI, with an optional ETag (to do a conditional fetch),-      -- write the resource to the given file and return the HTTP status code,-      -- and optional ETag.-      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]-               -> IO (HttpCode, Maybe ETag),--      -- | POST a resource to a URI, with optional auth (username, password)-      -- and return the HTTP status code and any redirect URL.-      postHttp :: Verbosity -> URI -> String -> Maybe Auth-               -> IO (HttpCode, String),--      -- | POST a file resource to a URI using multipart\/form-data encoding,-      -- with optional auth (username, password) and return the HTTP status-      -- code and any error string.-      postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth-                   -> IO (HttpCode, String),--      -- | PUT a file resource to a URI, with optional auth-      -- (username, password), extra headers and return the HTTP status code-      -- and any error string.-      putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]-                  -> IO (HttpCode, String),--      -- | Whether this transport supports https or just http.-      transportSupportsHttps :: Bool,--      -- | Whether this transport implementation was specifically chosen by-      -- the user via configuration, or whether it was automatically selected.-      -- Strictly speaking this is not a property of the transport itself but-      -- about how it was chosen. Nevertheless it's convenient to keep here.-      transportManuallySelected :: Bool-    }-    --TODO: why does postHttp return a redirect, but postHttpFile return errors?--type HttpCode = Int-type ETag     = String-type Auth     = (String, String)--noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)-          -> IO (Int, String)-noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet"--supportedTransports :: [(String, Maybe Program, Bool,-                         ProgramDb -> Maybe HttpTransport)]-supportedTransports =-    [ let prog = simpleProgram "curl" in-      ( "curl", Just prog, True-      , \db -> curlTransport <$> lookupProgram prog db )--    , let prog = simpleProgram "wget" in-      ( "wget", Just prog, True-      , \db -> wgetTransport <$> lookupProgram prog db )--    , let prog = simpleProgram "powershell" in-      ( "powershell", Just prog, True-      , \db -> powershellTransport <$> lookupProgram prog db )--    , ( "plain-http", Nothing, False-      , \_ -> Just plainHttpTransport )-    ]--configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport--configureTransport verbosity extraPath (Just name) =-    -- the user specifically selected a transport by name so we'll try and-    -- configure that one--    case find (\(name',_,_,_) -> name' == name) supportedTransports of-      Just (_, mprog, _tls, mkTrans) -> do--        let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb-        progdb <- case mprog of-          Nothing   -> return emptyProgramDb-          Just prog -> snd <$> requireProgram verbosity prog baseProgDb-                       --      ^^ if it fails, it'll fail here--        let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb-        return transport { transportManuallySelected = True }--      Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name-                    ++ ". The supported transports are "-                    ++ intercalate ", "-                         [ name' | (name', _, _, _ ) <- supportedTransports ]--configureTransport verbosity extraPath Nothing = do-    -- the user hasn't selected a transport, so we'll pick the first one we-    -- can configure successfully, provided that it supports tls--    -- for all the transports except plain-http we need to try and find-    -- their external executable-    let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb-    progdb <- configureAllKnownPrograms  verbosity $-                addKnownPrograms-                  [ prog | (_, Just prog, _, _) <- supportedTransports ]-                  baseProgDb--    let availableTransports =-          [ (name, transport)-          | (name, _, _, mkTrans) <- supportedTransports-          , transport <- maybeToList (mkTrans progdb) ]-    let (name, transport) =-         fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)-    debug verbosity $ "Selected http transport implementation: " ++ name--    return transport { transportManuallySelected = False }------------------------------------------------------------------------------------ The HttpTransports based on external programs-----curlTransport :: ConfiguredProgram -> HttpTransport-curlTransport prog =-    HttpTransport gethttp posthttp posthttpfile puthttpfile True False-  where-    gethttp verbosity uri etag destPath reqHeaders = do-        withTempFile (takeDirectory destPath)-                     "curl-headers.txt" $ \tmpFile tmpHandle -> do-          hClose tmpHandle-          let args = [ show uri-                   , "--output", destPath-                   , "--location"-                   , "--write-out", "%{http_code}"-                   , "--user-agent", userAgent-                   , "--silent", "--show-error"-                   , "--dump-header", tmpFile ]-                ++ concat-                   [ ["--header", "If-None-Match: " ++ t]-                   | t <- maybeToList etag ]-                ++ concat-                   [ ["--header", show name ++ ": " ++ value]-                   | Header name value <- reqHeaders ]--          resp <- getProgramInvocationOutput verbosity-                    (programInvocation prog args)-          withFile tmpFile ReadMode $ \hnd -> do-            headers <- hGetContents hnd-            (code, _err, etag') <- parseResponse verbosity uri resp headers-            evaluate $ force (code, etag')--    posthttp = noPostYet--    addAuthConfig auth progInvocation = progInvocation-      { progInvokeInput = do-          (uname, passwd) <- auth-          return $ IODataText $ unlines-            [ "--digest"-            , "--user " ++ uname ++ ":" ++ passwd-            ]-      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation-      }--    posthttpfile verbosity uri path auth = do-        let args = [ show uri-                   , "--form", "package=@"++path-                   , "--write-out", "\n%{http_code}"-                   , "--user-agent", userAgent-                   , "--silent", "--show-error"-                   , "--header", "Accept: text/plain"-                   , "--location"-                   ]-        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth-                  (programInvocation prog args)-        (code, err, _etag) <- parseResponse verbosity uri resp ""-        return (code, err)--    puthttpfile verbosity uri path auth headers = do-        let args = [ show uri-                   , "--request", "PUT", "--data-binary", "@"++path-                   , "--write-out", "\n%{http_code}"-                   , "--user-agent", userAgent-                   , "--silent", "--show-error"-                   , "--location"-                   , "--header", "Accept: text/plain"-                   ]-                ++ concat-                   [ ["--header", show name ++ ": " ++ value]-                   | Header name value <- headers ]-        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth-                  (programInvocation prog args)-        (code, err, _etag) <- parseResponse verbosity uri resp ""-        return (code, err)--    -- on success these curl invocations produces an output like "200"-    -- and on failure it has the server error response first-    parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)-    parseResponse verbosity uri resp headers =-      let codeerr =-            case reverse (lines resp) of-              (codeLine:rerrLines) ->-                case readMaybe (trim codeLine) of-                  Just i  -> let errstr = mkErrstr rerrLines-                              in Just (i, errstr)-                  Nothing -> Nothing-              []          -> Nothing--          mkErrstr = unlines . reverse . dropWhile (all isSpace)--          mb_etag :: Maybe ETag-          mb_etag  = listToMaybe $ reverse-                     [ etag-                     | ["ETag:", etag] <- map words (lines headers) ]--       in case codeerr of-            Just (i, err) -> return (i, err, mb_etag)-            _             -> statusParseFail verbosity uri resp---wgetTransport :: ConfiguredProgram -> HttpTransport-wgetTransport prog =-  HttpTransport gethttp posthttp posthttpfile puthttpfile True False-  where-    gethttp verbosity uri etag destPath reqHeaders =  do-        resp <- runWGet verbosity uri args--        -- wget doesn't support range requests.-        -- so, we not only ignore range request headers,-        -- but we also dispay a warning message when we see them.-        let hasRangeHeader =  any isRangeHeader reqHeaders-            warningMsg     =  "the 'wget' transport currently doesn't support"-                           ++ " range requests, which wastes network bandwidth."-                           ++ " To fix this, set 'http-transport' to 'curl' or"-                           ++ " 'plain-http' in '~/.cabal/config'."-                           ++ " Note that the 'plain-http' transport doesn't"-                           ++ " support HTTPS.\n"--        when (hasRangeHeader) $ warn verbosity warningMsg-        (code, etag') <- parseOutput verbosity uri resp-        return (code, etag')-      where-        args = [ "--output-document=" ++ destPath-               , "--user-agent=" ++ userAgent-               , "--tries=5"-               , "--timeout=15"-               , "--server-response" ]-            ++ concat-               [ ["--header", "If-None-Match: " ++ t]-               | t <- maybeToList etag ]-            ++ [ "--header=" ++ show name ++ ": " ++ value-               | hdr@(Header name value) <- reqHeaders-               , (not (isRangeHeader hdr)) ]--        -- wget doesn't support range requests.-        -- so, we ignore range request headers, lest we get errors.-        isRangeHeader :: Header -> Bool-        isRangeHeader (Header HdrRange _) = True-        isRangeHeader _ = False--    posthttp = noPostYet--    posthttpfile verbosity  uri path auth =-        withTempFile (takeDirectory path)-                     (takeFileName path) $ \tmpFile tmpHandle ->-        withTempFile (takeDirectory path) "response" $-        \responseFile responseHandle -> do-          hClose responseHandle-          (body, boundary) <- generateMultipartBody path-          LBS.hPut tmpHandle body-          hClose tmpHandle-          let args = [ "--post-file=" ++ tmpFile-                     , "--user-agent=" ++ userAgent-                     , "--server-response"-                     , "--output-document=" ++ responseFile-                     , "--header=Accept: text/plain"-                     , "--header=Content-type: multipart/form-data; " ++-                                              "boundary=" ++ boundary ]-          out <- runWGet verbosity (addUriAuth auth uri) args-          (code, _etag) <- parseOutput verbosity uri out-          withFile responseFile ReadMode $ \hnd -> do-            resp <- hGetContents hnd-            evaluate $ force (code, resp)--    puthttpfile verbosity uri path auth headers =-        withTempFile (takeDirectory path) "response" $-        \responseFile responseHandle -> do-            hClose responseHandle-            let args = [ "--method=PUT", "--body-file="++path-                       , "--user-agent=" ++ userAgent-                       , "--server-response"-                       , "--output-document=" ++ responseFile-                       , "--header=Accept: text/plain" ]-                    ++ [ "--header=" ++ show name ++ ": " ++ value-                       | Header name value <- headers ]--            out <- runWGet verbosity (addUriAuth auth uri) args-            (code, _etag) <- parseOutput verbosity uri out-            withFile responseFile ReadMode $ \hnd -> do-              resp <- hGetContents hnd-              evaluate $ force (code, resp)--    addUriAuth Nothing uri = uri-    addUriAuth (Just (user, pass)) uri = uri-      { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }-      }-     where-      a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)--    runWGet verbosity uri args = do-        -- We pass the URI via STDIN because it contains the users' credentials-        -- and sensitive data should not be passed via command line arguments.-        let-          invocation = (programInvocation prog ("--input-file=-" : args))-            { progInvokeInput = Just $ IODataText $ uriToString id uri ""-            }--        -- wget returns its output on stderr rather than stdout-        (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity-                                 invocation-        -- wget returns exit code 8 for server "errors" like "304 not modified"-        if exitCode == ExitSuccess || exitCode == ExitFailure 8-          then return resp-          else die' verbosity $ "'" ++ programPath prog-                  ++ "' exited with an error:\n" ++ resp--    -- With the --server-response flag, wget produces output with the full-    -- http server response with all headers, we want to find a line like-    -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple-    -- requests due to redirects.-    parseOutput verbosity uri resp =-      let parsedCode = listToMaybe-                     [ code-                     | (protocol:codestr:_err) <- map words (reverse (lines resp))-                     , "HTTP/" `isPrefixOf` protocol-                     , code <- maybeToList (readMaybe codestr) ]-          mb_etag :: Maybe ETag-          mb_etag  = listToMaybe-                    [ etag-                    | ["ETag:", etag] <- map words (reverse (lines resp)) ]-       in case parsedCode of-            Just i -> return (i, mb_etag)-            _      -> statusParseFail verbosity uri resp---powershellTransport :: ConfiguredProgram -> HttpTransport-powershellTransport prog =-    HttpTransport gethttp posthttp posthttpfile puthttpfile True False-  where-    gethttp verbosity uri etag destPath reqHeaders = do-      resp <- runPowershellScript verbosity $-        webclientScript-          (escape (show uri))-          (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")-          :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))-          [ "$response = $request.GetResponse()"-          , "$responseStream = $response.GetResponseStream()"-          , "$buffer = new-object byte[] 10KB"-          , "$count = $responseStream.Read($buffer, 0, $buffer.length)"-          , "while ($count -gt 0)"-          , "{"-          , "    $targetStream.Write($buffer, 0, $count)"-          , "    $count = $responseStream.Read($buffer, 0, $buffer.length)"-          , "}"-          , "Write-Host ($response.StatusCode -as [int]);"-          , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"-          ]-          [ "$targetStream.Flush()"-          , "$targetStream.Close()"-          , "$targetStream.Dispose()"-          , "$responseStream.Dispose()"-          ]-      parseResponse resp-      where-        parseResponse :: String -> IO (HttpCode, Maybe ETag)-        parseResponse x =-          case lines $ trim x of-            (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x-            (code:      _) -> fmap (\c -> (c, Nothing  )) $ parseCode code x-            _              -> statusParseFail verbosity uri x-        parseCode :: String -> String -> IO HttpCode-        parseCode code x = case readMaybe code of-          Just i  -> return i-          Nothing -> statusParseFail verbosity uri x-        etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]--    posthttp = noPostYet--    posthttpfile verbosity uri path auth =-      withTempFile (takeDirectory path)-                   (takeFileName path) $ \tmpFile tmpHandle -> do-        (body, boundary) <- generateMultipartBody path-        LBS.hPut tmpHandle body-        hClose tmpHandle-        fullPath <- canonicalizePath tmpFile--        let contentHeader = Header HdrContentType-              ("multipart/form-data; boundary=" ++ boundary)-        resp <- runPowershellScript verbosity $ webclientScript-          (escape (show uri))-          (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)-          (uploadFileAction "POST" uri fullPath)-          uploadFileCleanup-        parseUploadResponse verbosity uri resp--    puthttpfile verbosity uri path auth headers = do-      fullPath <- canonicalizePath path-      resp <- runPowershellScript verbosity $ webclientScript-        (escape (show uri))-        (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)-        (uploadFileAction "PUT" uri fullPath)-        uploadFileCleanup-      parseUploadResponse verbosity uri resp--    runPowershellScript verbosity script = do-      let args =-            [ "-InputFormat", "None"-            -- the default execution policy doesn't allow running-            -- unsigned scripts, so we need to tell powershell to bypass it-            , "-ExecutionPolicy", "bypass"-            , "-NoProfile", "-NonInteractive"-            , "-Command", "-"-            ]-      debug verbosity script-      getProgramInvocationOutput verbosity (programInvocation prog args)-        { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"-        }--    escape = show--    useragentHeader = Header HdrUserAgent userAgent-    extraHeaders = [Header HdrAccept "text/plain", useragentHeader]--    setupHeaders headers =-      [ "$request." ++ addHeader name value-      | Header name value <- headers-      ]-      where-        addHeader header value-          = case header of-              HdrAccept           -> "Accept = "           ++ escape value-              HdrUserAgent        -> "UserAgent = "        ++ escape value-              HdrConnection       -> "Connection = "       ++ escape value-              HdrContentLength    -> "ContentLength = "    ++ escape value-              HdrContentType      -> "ContentType = "      ++ escape value-              HdrDate             -> "Date = "             ++ escape value-              HdrExpect           -> "Expect = "           ++ escape value-              HdrHost             -> "Host = "             ++ escape value-              HdrIfModifiedSince  -> "IfModifiedSince = "  ++ escape value-              HdrReferer          -> "Referer = "          ++ escape value-              HdrTransferEncoding -> "TransferEncoding = " ++ escape value-              HdrRange            -> let (start, end) =-                                          if "bytes=" `isPrefixOf` value-                                             then case break (== '-') value' of-                                                 (start', '-':end') -> (start', end')-                                                 _                  -> error $ "Could not decode range: " ++ value-                                             else error $ "Could not decode range: " ++ value-                                         value' = drop 6 value-                                     in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"-              name                -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"--    setupAuth auth =-      [ "$request.Credentials = new-object System.Net.NetworkCredential("-          ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"-      | (uname,passwd) <- maybeToList auth-      ]--    uploadFileAction method _uri fullPath =-      [ "$request.Method = " ++ show method-      , "$requestStream = $request.GetRequestStream()"-      , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"-      , "$bufSize=10000"-      , "$chunk = New-Object byte[] $bufSize"-      , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"-      , "{"-      , "  $requestStream.write($chunk, 0, $bytesRead)"-      , "  $requestStream.Flush()"-      , "}"-      , ""-      , "$responseStream = $request.getresponse()"-      , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"-      , "$code = $response.StatusCode -as [int]"-      , "if ($code -eq 0) {"-      , "  $code = 200;"-      , "}"-      , "Write-Host $code"-      , "Write-Host $responseReader.ReadToEnd()"-      ]--    uploadFileCleanup =-      [ "$fileStream.Close()"-      , "$requestStream.Close()"-      , "$responseStream.Close()"-      ]--    parseUploadResponse verbosity uri resp = case lines (trim resp) of-      (codeStr : message)-        | Just code <- readMaybe codeStr -> return (code, unlines message)-      _ -> statusParseFail verbosity uri resp--    webclientScript uri setup action cleanup = unlines-      [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""-      , "$uri = New-Object \"System.Uri\" " ++ uri-      , "$request = [System.Net.HttpWebRequest]::Create($uri)"-      , unlines setup-      , "Try {"-      , unlines (map ("  " ++) action)-      , "} Catch [System.Net.WebException] {"-      , "  $exception = $_.Exception;"-      , "  If ($exception.Status -eq "-        ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"-      , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"-      , "    $reader = new-object "-        ++ "System.IO.StreamReader($response.GetResponseStream());"-      , "    Write-Host ($response.StatusCode -as [int]);"-      , "    Write-Host $reader.ReadToEnd();"-      , "  } Else {"-      , "    Write-Host $exception.Message;"-      , "  }"-      , "} Catch {"-      , "  Write-Host $_.Exception.Message;"-      , "} finally {"-      , unlines (map ("  " ++) cleanup)-      , "}"-      ]------------------------------------------------------------------------------------ The builtin plain HttpTransport-----plainHttpTransport :: HttpTransport-plainHttpTransport =-    HttpTransport gethttp posthttp posthttpfile puthttpfile False False-  where-    gethttp verbosity uri etag destPath reqHeaders = do-      let req = Request{-                  rqURI     = uri,-                  rqMethod  = GET,-                  rqHeaders = [ Header HdrIfNoneMatch t-                              | t <- maybeToList etag ]-                           ++ reqHeaders,-                  rqBody    = LBS.empty-                }-      (_, resp) <- cabalBrowse verbosity Nothing (request req)-      let code  = convertRspCode (rspCode resp)-          etag' = lookupHeader HdrETag (rspHeaders resp)-      -- 206 Partial Content is a normal response to a range request; see #3385.-      when (code==200 || code==206) $-        writeFileAtomic destPath $ rspBody resp-      return (code, etag')--    posthttp = noPostYet--    posthttpfile verbosity uri path auth = do-      (body, boundary) <- generateMultipartBody path-      let headers = [ Header HdrContentType-                             ("multipart/form-data; boundary="++boundary)-                    , Header HdrContentLength (show (LBS8.length body))-                    , Header HdrAccept ("text/plain")-                    ]-          req = Request {-                  rqURI     = uri,-                  rqMethod  = POST,-                  rqHeaders = headers,-                  rqBody    = body-                }-      (_, resp) <- cabalBrowse verbosity auth (request req)-      return (convertRspCode (rspCode resp), rspErrorString resp)--    puthttpfile verbosity uri path auth headers = do-      body <- LBS8.readFile path-      let req = Request {-                  rqURI     = uri,-                  rqMethod  = PUT,-                  rqHeaders = Header HdrContentLength (show (LBS8.length body))-                            : Header HdrAccept "text/plain"-                            : headers,-                  rqBody    = body-                }-      (_, resp) <- cabalBrowse verbosity auth (request req)-      return (convertRspCode (rspCode resp), rspErrorString resp)--    convertRspCode (a,b,c) = a*100 + b*10 + c--    rspErrorString resp =-      case lookupHeader HdrContentType (rspHeaders resp) of-        Just contenttype-           | takeWhile (/= ';') contenttype == "text/plain"-          -> LBS8.unpack (rspBody resp)-        _ -> rspReason resp--    cabalBrowse verbosity auth act = do-      p <- fixupEmptyProxy <$> fetchProxy True-      Exception.handleJust-        (guard . isDoesNotExistError)-        (const . die' verbosity $ "Couldn't establish HTTP connection. "-                    ++ "Possible cause: HTTP proxy server is down.") $-        browse $ do-          setProxy p-          setErrHandler (warn verbosity . ("http error: "++))-          setOutHandler (debug verbosity)-          setUserAgent  userAgent-          setAllowBasicAuth False-          setAuthorityGen (\_ _ -> return auth)-          act--    fixupEmptyProxy (Proxy uri _) | null uri = NoProxy-    fixupEmptyProxy p = p------------------------------------------------------------------------------------ Common stuff used by multiple transport impls-----userAgent :: String-userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion-                   , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")"-                   ]--statusParseFail :: Verbosity -> URI -> String -> IO a-statusParseFail verbosity uri r =-    die' verbosity $ "Failed to download " ++ show uri ++ " : "-       ++ "No Status Code could be parsed from response: " ++ r---- Trim-trim :: String -> String-trim = f . f-      where f = reverse . dropWhile isSpace------------------------------------------------------------------------------------ Multipart stuff partially taken from cgi package.-----generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)-generateMultipartBody path = do-    content  <- LBS.readFile path-    boundary <- genBoundary-    let !body = formatBody content (LBS8.pack boundary)-    return (body, boundary)-  where-    formatBody content boundary =-        LBS8.concat $-        [ crlf, dd, boundary, crlf ]-     ++ [ LBS8.pack (show header) | header <- headers ]-     ++ [ crlf-        , content-        , crlf, dd, boundary, dd, crlf ]--    headers =-      [ Header (HdrCustom "Content-disposition")-               ("form-data; name=package; " ++-                "filename=\"" ++ takeFileName path ++ "\"")-      , Header HdrContentType "application/x-gzip"-      ]--    crlf = LBS8.pack "\r\n"-    dd   = LBS8.pack "--"--genBoundary :: IO String-genBoundary = do-    i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer-    return $ showHex i ""
− Distribution/Client/IndexUtils.hs 
@@ -1,1180 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.IndexUtils--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org--- Stability   :  provisional--- Portability :  portable------ Extra utils related to the package indexes.-------------------------------------------------------------------------------module Distribution.Client.IndexUtils (-  getIndexFileAge,-  getInstalledPackages,-  indexBaseName,-  Configure.getInstalledPackagesMonitorFiles,-  getSourcePackages,-  getSourcePackagesMonitorFiles,--  TotalIndexState,-  getSourcePackagesAtIndexState,-  ActiveRepos,-  filterSkippedActiveRepos,--  Index(..),-  RepoIndexState (..),-  PackageEntry(..),-  parsePackageIndex,-  updateRepoIndexCache,-  updatePackageIndexCacheFile,-  writeIndexTimestamp,-  currentIndexTimestamp,--  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Archive.Tar.Index as Tar-import qualified Distribution.Client.Tar as Tar-import Distribution.Client.IndexUtils.ActiveRepos-import Distribution.Client.IndexUtils.IndexState-import Distribution.Client.IndexUtils.Timestamp-import Distribution.Client.Types-import Distribution.Verbosity-import Distribution.Parsec (simpleParsecBS)--import Distribution.Package-         ( PackageId, PackageIdentifier(..), mkPackageName-         , Package(..), packageVersion, packageName )-import Distribution.Types.Dependency-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription-         ( GenericPackageDescription(..)-         , PackageDescription(..), emptyPackageDescription )-import Distribution.Simple.Compiler-         ( Compiler, PackageDBStack )-import Distribution.Simple.Program-         ( ProgramDb )-import qualified Distribution.Simple.Configure as Configure-         ( getInstalledPackages, getInstalledPackagesMonitorFiles )-import Distribution.Types.PackageName (PackageName)-import Distribution.Version-         ( Version, VersionRange, mkVersion, intersectVersionRanges )-import Distribution.Simple.Utils-         ( die', warn, info, createDirectoryIfMissingVerbose )-import Distribution.Client.Setup-         ( RepoContext(..) )--import Distribution.PackageDescription.Parsec-         ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe )-import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse--import           Distribution.Solver.Types.PackageIndex (PackageIndex)-import qualified Distribution.Solver.Types.PackageIndex as PackageIndex-import           Distribution.Solver.Types.SourcePackage--import qualified Data.Map as Map-import qualified Data.Set as Set-import Control.Exception-import Data.List (stripPrefix)-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import qualified Data.ByteString.Char8 as BSS-import Data.ByteString.Lazy (ByteString)-import Distribution.Client.GZipUtils (maybeDecompress)-import Distribution.Client.Utils ( byteStringToFilePath-                                 , tryFindAddSourcePackageDesc )-import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail)-import Distribution.Compat.Time (getFileAge, getModTime)-import System.Directory (doesFileExist, doesDirectoryExist)-import System.FilePath-         ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory )-import qualified System.FilePath.Posix as FilePath.Posix-import System.IO-import System.IO.Unsafe (unsafeInterleaveIO)-import System.IO.Error (isDoesNotExistError)-import Distribution.Compat.Directory (listDirectory)-import Distribution.Utils.Generic (fstOf3)--import qualified Codec.Compression.GZip as GZip--import qualified Hackage.Security.Client    as Sec-import qualified Hackage.Security.Util.Some as Sec---- | Reduced-verbosity version of 'Configure.getInstalledPackages'-getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -> ProgramDb-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity comp packageDbs progdb =-    Configure.getInstalledPackages verbosity' comp packageDbs progdb-  where-    verbosity'  = lessVerbose verbosity----- | Get filename base (i.e. without file extension) for index-related files------ /Secure/ cabal repositories use a new extended & incremental--- @01-index.tar@. In order to avoid issues resulting from clobbering--- new/old-style index data, we save them locally to different names.------ Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the--- @00-index.tar.gz@/@01-index.tar.gz@ file.-indexBaseName :: Repo -> FilePath-indexBaseName repo = repoLocalDir repo </> fn-  where-    fn = case repo of-           RepoSecure {}       -> "01-index"-           RepoRemote {}       -> "00-index"-           RepoLocalNoIndex {} -> "noindex"----------------------------------------------------------------------------- Reading the source package index------- Note: 'data IndexState' is defined in--- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles---- | 'IndexStateInfo' contains meta-information about the resulting--- filtered 'Cache' 'after applying 'filterCache' according to a--- requested 'IndexState'.-data IndexStateInfo = IndexStateInfo-    { isiMaxTime  :: !Timestamp-    -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current-    -- filtered view of the cache.-    ---    -- The following property holds-    ---    -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)-    ----    , isiHeadTime :: !Timestamp-    -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest-    -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to-    -- 'isiMaxTime'.-    }--emptyStateInfo :: IndexStateInfo-emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp---- | Filters a 'Cache' according to an 'IndexState'--- specification. Also returns 'IndexStateInfo' describing the--- resulting index cache.------ Note: 'filterCache' is idempotent in the 'Cache' value-filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo)-filterCache IndexStateHead cache = (cache, IndexStateInfo{..})-  where-    isiMaxTime  = cacheHeadTs cache-    isiHeadTime = cacheHeadTs cache-filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})-  where-    cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime }-    isiHeadTime = cacheHeadTs cache0-    isiMaxTime  = maximumTimestamp (map cacheEntryTimestamp ents)-    ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)---- | Read a repository index from disk, from the local files specified by--- a list of 'Repo's.------ All the 'SourcePackage's are marked as having come from the appropriate--- 'Repo'.------ This is a higher level wrapper used internally in cabal-install.-getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb-getSourcePackages verbosity repoCtxt =-    fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing---- | Variant of 'getSourcePackages' which allows getting the source--- packages at a particular 'IndexState'.------ Current choices are either the latest (aka HEAD), or the index as--- it was at a particular time.------ Returns also the total index where repositories'--- RepoIndexState's are not HEAD. This is used in v2-freeze.----getSourcePackagesAtIndexState-    :: Verbosity-    -> RepoContext-    -> Maybe TotalIndexState-    -> Maybe ActiveRepos-    -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)-getSourcePackagesAtIndexState verbosity repoCtxt _ _-  | null (repoContextRepos repoCtxt) = do-      -- In the test suite, we routinely don't have any remote package-      -- servers, so don't bleat about it-      warn (verboseUnmarkOutput verbosity) $-        "No remote package servers have been specified. Usually " ++-        "you would have one specified in the config file."-      return (SourcePackageDb {-        packageIndex       = mempty,-        packagePreferences = mempty-      }, headTotalIndexState, ActiveRepos [])-getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do-  let describeState IndexStateHead        = "most recent state"-      describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time--  pkgss <- for (repoContextRepos repoCtxt) $ \r -> do-      let rname :: RepoName-          rname = repoName r--      info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")--      idxState <- case mb_idxState of-        Just totalIdxState -> do-          let idxState = lookupIndexState rname totalIdxState-          info verbosity $ "Using " ++ describeState idxState ++-            " as explicitly requested (via command line / project configuration)"-          return idxState-        Nothing -> do-          mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r)-          case mb_idxState' of-            Nothing -> do-              info verbosity "Using most recent state (could not read timestamp file)"-              return IndexStateHead-            Just idxState -> do-              info verbosity $ "Using " ++ describeState idxState ++-                " specified from most recent cabal update"-              return idxState--      unless (idxState == IndexStateHead) $-          case r of-            RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories"-            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")-            RepoSecure {} -> pure ()--      let idxState' = case r of-            RepoSecure {} -> idxState-            _             -> IndexStateHead--      (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState'--      case idxState' of-        IndexStateHead -> do-            info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi))-            return ()-        IndexStateTime ts0 -> do-            when (isiMaxTime isi /= ts0) $-                if ts0 > isiMaxTime isi-                    then warn verbosity $-                                   "Requested index-state " ++ prettyShow ts0-                                ++ " is newer than '" ++ unRepoName rname ++ "'!"-                                ++ " Falling back to older state ("-                                ++ prettyShow (isiMaxTime isi) ++ ")."-                    else info verbosity $-                                   "Requested index-state " ++ prettyShow ts0-                                ++ " does not exist in '"++ unRepoName rname ++"'!"-                                ++ " Falling back to older state ("-                                ++ prettyShow (isiMaxTime isi) ++ ")."-            info verbosity ("index-state("++ unRepoName rname ++") = " ++-                              prettyShow (isiMaxTime isi) ++ " (HEAD = " ++-                              prettyShow (isiHeadTime isi) ++ ")")--      pure RepoData-          { rdRepoName    = rname-          , rdTimeStamp   = isiMaxTime isi-          , rdIndex       = pis-          , rdPreferences = deps-          }--  let activeRepos :: ActiveRepos-      activeRepos = fromMaybe defaultActiveRepos mb_activeRepos--  pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of-    Right x  -> return x-    Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)--  let activeRepos' :: ActiveRepos-      activeRepos' = ActiveRepos-          [ ActiveRepo (rdRepoName rd) strategy-          | (rd, strategy) <- pkgss'-          ]--  let totalIndexState :: TotalIndexState-      totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList-          [ (n, IndexStateTime ts)-          | (RepoData n ts _idx _prefs, _strategy) <- pkgss'-          -- e.g. file+noindex have nullTimestamp as their timestamp-          , ts /= nullTimestamp-          ]--  let addIndex-          :: PackageIndex UnresolvedSourcePackage-          -> (RepoData, CombineStrategy)-          -> PackageIndex UnresolvedSourcePackage-      addIndex acc (RepoData _ _ _   _, CombineStrategySkip)     = acc-      addIndex acc (RepoData _ _ idx _, CombineStrategyMerge)    = PackageIndex.merge acc idx-      addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx--  let pkgs :: PackageIndex UnresolvedSourcePackage-      pkgs = foldl' addIndex mempty pkgss'--  -- Note: preferences combined without using CombineStrategy-  let prefs :: Map PackageName VersionRange-      prefs = Map.fromListWith intersectVersionRanges-          [ (name, range)-          | (RepoData _n _ts _idx prefs', _strategy) <- pkgss'-          , Dependency name range _ <- prefs'-          ]--  _ <- evaluate pkgs-  _ <- evaluate prefs-  _ <- evaluate totalIndexState-  return (SourcePackageDb {-    packageIndex       = pkgs,-    packagePreferences = prefs-  }, totalIndexState, activeRepos')---- auxiliary data used in getSourcePackagesAtIndexState-data RepoData = RepoData-    { rdRepoName    :: RepoName-    , rdTimeStamp   :: Timestamp-    , rdIndex       :: PackageIndex UnresolvedSourcePackage-    , rdPreferences :: [Dependency]-    }---- | Read a repository index from disk, from the local file specified by--- the 'Repo'.------ All the 'SourcePackage's are marked as having come from the given 'Repo'.------ This is a higher level wrapper used internally in cabal-install.----readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState-              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)-readRepoIndex verbosity repoCtxt repo idxState =-  handleNotFound $ do-    when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo-    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)-    readPackageIndexCacheFile verbosity mkAvailablePackage-                              (RepoIndex repoCtxt repo)-                              idxState--  where-    mkAvailablePackage pkgEntry = SourcePackage-      { srcpkgPackageId   = pkgid-      , srcpkgDescription = pkgdesc-      , srcpkgSource      = case pkgEntry of-          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing-          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path-      , srcpkgDescrOverride = case pkgEntry of-          NormalPackage _ _ pkgtxt _ -> Just pkgtxt-          _                          -> Nothing-      }-      where-        pkgdesc = packageDesc pkgEntry-        pkgid = packageId pkgEntry--    handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e-      then do-        case repo of-          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote-          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote-          RepoLocalNoIndex local _ -> warn verbosity $-              "Error during construction of local+noindex "-              ++ unRepoName (localRepoName local) ++ " repository index: "-              ++ show e-        return (mempty,mempty,emptyStateInfo)-      else ioError e--    isOldThreshold = 15 --days-    warnIfIndexIsOld dt = do-      when (dt >= isOldThreshold) $ case repo of-        RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt-        RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt-        RepoLocalNoIndex {} -> return ()--    errMissingPackageList repoRemote =-         "The package list for '" ++ unRepoName (remoteRepoName repoRemote)-      ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote-    errOutdatedPackageList repoRemote dt =-         "The package list for '" ++ unRepoName (remoteRepoName repoRemote)-      ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "-      ++ "'cabal update' to get the latest list of available packages."---- | Return the age of the index file in days (as a Double).-getIndexFileAge :: Repo -> IO Double-getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"---- | A set of files (or directories) that can be monitored to detect when--- there might have been a change in the source packages.----getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]-getSourcePackagesMonitorFiles repos =-    concat [ [ indexBaseName repo <.> "cache"-             , indexBaseName repo <.> "timestamp" ]-           | repo <- repos ]---- | It is not necessary to call this, as the cache will be updated when the--- index is read normally. However you can do the work earlier if you like.----updateRepoIndexCache :: Verbosity -> Index -> IO ()-updateRepoIndexCache verbosity index =-    whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index--whenCacheOutOfDate :: Index -> IO () -> IO ()-whenCacheOutOfDate index action = do-  exists <- doesFileExist $ cacheFile index-  if not exists-  then action-  else if localNoIndex index-      then return () -- TODO: don't update cache for local+noindex repositories-      else do-          indexTime <- getModTime $ indexFile index-          cacheTime <- getModTime $ cacheFile index-          when (indexTime > cacheTime) action--localNoIndex :: Index -> Bool-localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True-localNoIndex _ = False----------------------------------------------------------------------------- Reading the index file------- | An index entry is either a normal package, or a local build tree reference.-data PackageEntry-  = NormalPackage  PackageId GenericPackageDescription ByteString BlockNo-  | BuildTreeRef BuildTreeRefType-                 PackageId GenericPackageDescription FilePath   BlockNo---- | A build tree reference is either a link or a snapshot.-data BuildTreeRefType = SnapshotRef | LinkRef-                      deriving (Eq,Show,Generic)--instance Binary BuildTreeRefType-instance Structured BuildTreeRefType--refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType-refTypeFromTypeCode t-  | t == Tar.buildTreeRefTypeCode      = LinkRef-  | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef-  | otherwise                          =-    error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"--typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode-typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode-typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode--instance Package PackageEntry where-  packageId (NormalPackage  pkgid _ _ _) = pkgid-  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid--packageDesc :: PackageEntry -> GenericPackageDescription-packageDesc (NormalPackage  _ descr _ _) = descr-packageDesc (BuildTreeRef _ _ descr _ _) = descr---- | Parse an uncompressed \"00-index.tar\" repository index file represented--- as a 'ByteString'.-----data PackageOrDep = Pkg PackageEntry | Dep Dependency---- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files------ We read the index using 'Tar.read', which gives us a lazily constructed--- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',--- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a--- function over this to translate it to a list of IO actions returning--- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of--- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.-parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]-parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read-  where-    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]-    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs-      where-        tryExtractPkg = do-          mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo-          return $ fmap (fmap Pkg) mkPkgEntry--        tryExtractPrefs = do-          prefs' <- maybeToList $ extractPrefs entry-          fmap (return . Just . Dep) prefs'---- | Turn the 'Entries' data structure from the @tar@ package into a list,--- and pair each entry with its block number.------ NOTE: This preserves the lazy nature of 'Entries': the tar file is only read--- as far as the list is evaluated.-tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]-tarEntriesList = go 0-  where-    go !_ Tar.Done         = []-    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)-    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'--extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))-extractPkg verbosity entry blockNo = case Tar.entryContent entry of-  Tar.NormalFile content _-     | takeExtension fileName == ".cabal"-    -> case splitDirectories (normalise fileName) of-        [pkgname,vers,_] -> case simpleParsec vers of-          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)-            where-              pkgid  = PackageIdentifier (mkPackageName pkgname) ver-              parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)-              descr = case parsed of-                  Just d  -> d-                  Nothing -> error $ "Couldn't read cabal file "-                                    ++ show fileName-          _ -> Nothing-        _ -> Nothing--  Tar.OtherEntryType typeCode content _-    | Tar.isBuildTreeRefTypeCode typeCode ->-      Just $ do-        let path = byteStringToFilePath content-        dirExists <- doesDirectoryExist path-        result <- if not dirExists then return Nothing-                  else do-                    cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index."-                    descr     <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile-                    return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)-                                                 descr path blockNo-        return result--  _ -> Nothing--  where-    fileName = Tar.entryPath entry--extractPrefs :: Tar.Entry -> Maybe [Dependency]-extractPrefs entry = case Tar.entryContent entry of-  Tar.NormalFile content _-     | FilePath.Posix.takeFileName entrypath == "preferred-versions"-    -> Just prefs-    where-      entrypath = Tar.entryPath entry-      prefs     = parsePreferredVersions content-  _ -> Nothing--parsePreferredVersions :: ByteString -> [Dependency]-parsePreferredVersions = mapMaybe simpleParsec-                       . filter (not . isPrefixOf "--")-                       . lines-                       . BS.Char8.unpack -- TODO: Are we sure no unicode?----------------------------------------------------------------------------- Reading and updating the index cache------- | Variation on 'sequence' which evaluates the actions lazily------ Pattern matching on the result list will execute just the first action;--- more generally pattern matching on the first @n@ '(:)' nodes will execute--- the first @n@ actions.-lazySequence :: [IO a] -> IO [a]-lazySequence = unsafeInterleaveIO . go-  where-    go []     = return []-    go (x:xs) = do x'  <- x-                   xs' <- lazySequence xs-                   return (x' : xs')---- | A lazy unfolder for lookup operations which return the current--- value and (possibly) the next key-lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]-lazyUnfold step = goLazy . Just-  where-    goLazy s = unsafeInterleaveIO (go s)--    go Nothing  = return []-    go (Just k) = do-        (v, mk') <- step k-        vs' <- goLazy mk'-        return ((k,v):vs')---- | Which index do we mean?-data Index =-    -- | The main index for the specified repository-    RepoIndex RepoContext Repo--    -- | A sandbox-local repository-    -- Argument is the location of the index file-  | SandboxIndex FilePath--indexFile :: Index -> FilePath-indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"-indexFile (SandboxIndex index)   = index--cacheFile :: Index -> FilePath-cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"-cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"--timestampFile :: Index -> FilePath-timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"-timestampFile (SandboxIndex index)   = index `replaceExtension` "timestamp"---- | Return 'True' if 'Index' uses 01-index format (aka secure repo)-is01Index :: Index -> Bool-is01Index (RepoIndex _ repo) = case repo of-                                 RepoSecure {} -> True-                                 RepoRemote {} -> False-                                 RepoLocalNoIndex {} -> True-is01Index (SandboxIndex _)   = False---updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()-updatePackageIndexCacheFile verbosity index = do-    info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")-    withIndexEntries verbosity index callback callbackNoIndex-  where-    callback entries = do-        let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)-            cache = Cache { cacheHeadTs  = maxTs-                          , cacheEntries = entries-                          }-        writeIndexCache index cache-        info verbosity ("Index cache updated to index-state "-                        ++ prettyShow (cacheHeadTs cache))--    callbackNoIndex entries = do-        writeNoIndexCache verbosity index $ NoIndexCache entries-        info verbosity "Index cache updated"---- | Read the index (for the purpose of building a cache)------ The callback is provided with list of cache entries, which is guaranteed to--- be lazily constructed. This list must ONLY be used in the scope of the--- callback; when the callback is terminated the file handle to the index will--- be closed and further attempts to read from the list will result in (pure)--- I/O exceptions.------ In the construction of the index for a secure repo we take advantage of the--- index built by the @hackage-security@ library to avoid reading the @.tar@--- file as much as possible (we need to read it only to extract preferred--- versions). This helps performance, but is also required for correctness:--- the new @01-index.tar.gz@ may have multiple versions of preferred-versions--- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);--- by reading the already-built cache from the security library we will be sure--- to only read the latest versions of all files.------ TODO: It would be nicer if we actually incrementally updated @cabal@'s--- cache, rather than reconstruct it from zero on each update. However, this--- would require a change in the cache format.-withIndexEntries-    :: Verbosity -> Index-    -> ([IndexCacheEntry] -> IO a)-    -> ([NoIndexCacheEntry] -> IO a)-    -> IO a-withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ =-    repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->-      Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do-        -- Incrementally (lazily) read all the entries in the tar file in order,-        -- including all revisions, not just the last revision of each file-        indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)-        callback [ cacheEntry-                 | (dirEntry, indexEntry) <- indexEntries-                 , cacheEntry <- toCacheEntries dirEntry indexEntry ]-  where-    toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry-                   -> [IndexCacheEntry]-    toCacheEntries dirEntry (Sec.Some sie) =-        case Sec.indexEntryPathParsed sie of-          Nothing                            -> [] -- skip unrecognized file-          Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata-          Just (Sec.IndexPkgCabal pkgId)     -> force-              [CachePackageId pkgId blockNo timestamp]-          Just (Sec.IndexPkgPrefs _pkgName)  -> force-              [ CachePreference dep blockNo timestamp-              | dep <- parsePreferredVersions (Sec.indexEntryContent sie)-              ]-      where-        blockNo = Sec.directoryEntryBlockNo dirEntry-        timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $-                              epochTimeToTimestamp $ Sec.indexEntryTime sie--withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do-    dirContents <- listDirectory localDir-    let contentSet = Set.fromList dirContents--    entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do-        case isTarGz file of-            Nothing -> do-                unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $-                    info verbosity $ "Skipping " ++ file-                return Nothing-            Just pkgid | cabalPath `Set.member` contentSet -> do-                contents <- BSS.readFile (localDir </> cabalPath)-                for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->-                    return (CacheGPD gpd contents)-              where-                cabalPath = prettyShow pkgid ++ ".cabal"-            Just pkgId -> do-                -- check for the right named .cabal file in the compressed tarball-                tarGz <- BS.readFile (localDir </> file)-                let tar = GZip.decompress tarGz-                    entries = Tar.read tar--                case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of-                    Just ce -> return (Just ce)-                    Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file--    info verbosity $ "Entries in file+noindex repository " ++ unRepoName name-    for_ entries $ \(CacheGPD gpd _) ->-        info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)--    callback entries-  where-    handler :: IOException -> IO a-    handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e--    isTarGz :: FilePath -> Maybe PackageIdentifier-    isTarGz fp = do-        pfx <- stripSuffix ".tar.gz" fp-        simpleParsec pfx--    stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str))--    -- look for <pkgid>/<pkgname>.cabal inside the tarball-    readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry-    readCabalEntry pkgId entry Nothing-        | filename == Tar.entryPath entry-        , Tar.NormalFile contents _ <- Tar.entryContent entry-        = let bs = BS.toStrict contents-          in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs-      where-        filename =  prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"-    readCabalEntry _ _ x = x--withIndexEntries verbosity index callback _ = do -- non-secure repositories-    withFile (indexFile index) ReadMode $ \h -> do-      bs          <- maybeDecompress `fmap` BS.hGetContents h-      pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs-      callback $ map toCache (catMaybes pkgsOrPrefs)-  where-    toCache :: PackageOrDep -> IndexCacheEntry-    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp-    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo-    toCache (Dep d) = CachePreference d 0 nullTimestamp--readPackageIndexCacheFile :: Package pkg-                          => Verbosity-                          -> (PackageEntry -> pkg)-                          -> Index-                          -> RepoIndexState-                          -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)-readPackageIndexCacheFile verbosity mkPkg index idxState-    | localNoIndex index = do-        cache0 <- readNoIndexCache verbosity index-        pkgs   <- packageNoIndexFromCache verbosity mkPkg cache0-        pure (pkgs, [], emptyStateInfo)--    | otherwise = do-        cache0   <- readIndexCache verbosity index-        indexHnd <- openFile (indexFile index) ReadMode-        let (cache,isi) = filterCache idxState cache0-        (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache-        pure (pkgs,deps,isi)--packageIndexFromCache :: Package pkg-                      => Verbosity-                     -> (PackageEntry -> pkg)-                      -> Handle-                      -> Cache-                      -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache verbosity mkPkg hnd cache = do-     (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache-     pkgIndex <- evaluate $ PackageIndex.fromList pkgs-     return (pkgIndex, prefs)--packageNoIndexFromCache-    :: forall pkg. Package pkg-    => Verbosity-    -> (PackageEntry -> pkg)-    -> NoIndexCache-    -> IO (PackageIndex pkg)-packageNoIndexFromCache _verbosity mkPkg cache =-     evaluate $ PackageIndex.fromList pkgs-  where-    pkgs =-        [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0-        | CacheGPD gpd bs <- noIndexCacheEntries cache-        , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd-        ]---- | Read package list------ The result package releases and preference entries are guaranteed--- to be unique.------ Note: 01-index.tar is an append-only index and therefore contains--- all .cabal edits and preference-updates. The masking happens--- here, i.e. the semantics that later entries in a tar file mask--- earlier ones is resolved in this function.-packageListFromCache :: Verbosity-                     -> (PackageEntry -> pkg)-                     -> Handle-                     -> Cache-                     -> IO ([pkg], [Dependency])-packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries-  where-    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)--    accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do-      -- Given the cache entry, make a package index entry.-      -- The magic here is that we use lazy IO to read the .cabal file-      -- from the index tarball if it turns out that we need it.-      -- Most of the time we only need the package id.-      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do-        pkgtxt <- getEntryContent blockno-        pkg    <- readPackageDescription pkgid pkgtxt-        return (pkg, pkgtxt)--      let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)-      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries--    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do-      -- We have to read the .cabal file eagerly here because we can't cache the-      -- 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 let err = "Error reading package index from cache."-                 file <- tryFindAddSourcePackageDesc verbosity path err-                 PackageDesc.Parse.readGenericPackageDescription normal file-      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)-      accum srcpkgs (srcpkg:btrs) prefs entries--    accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) =-      accum srcpkgs btrs (Map.insert pn pref prefs) entries--    getEntryContent :: BlockNo -> IO ByteString-    getEntryContent blockno = do-      entry <- Tar.hReadEntry hnd blockno-      case Tar.entryContent entry of-        Tar.NormalFile content _size -> return content-        Tar.OtherEntryType typecode content _size-          | Tar.isBuildTreeRefTypeCode typecode-          -> return content-        _ -> interror "unexpected tar entry type"--    readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription-    readPackageDescription pkgid content =-      case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of-        Right gpd                                           -> return gpd-        Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer)-        Left _                                              -> interror "failed to parse .cabal file"-      where-        dummyPackageDescription :: Version -> GenericPackageDescription-        dummyPackageDescription specVer = GenericPackageDescription-            { packageDescription = emptyPackageDescription-                                   { package     = pkgid-                                   , synopsis    = dummySynopsis-                                   }-            , gpdScannedVersion = Just specVer -- tells index scanner to skip this file.-            , genPackageFlags  = []-            , condLibrary      = Nothing-            , condSubLibraries = []-            , condForeignLibs  = []-            , condExecutables  = []-            , condTestSuites   = []-            , condBenchmarks   = []-            }--        dummySynopsis = "<could not be parsed due to unsupported CABAL spec-version>"--    interror :: String -> IO a-    interror msg = die' verbosity $ "internal error when reading package index: " ++ msg-                      ++ "The package index or index cache is probably "-                      ++ "corrupt. Running cabal update might fix it."------------------------------------------------------------------------------- Index cache data structure ------ | Read the 'Index' cache from the filesystem------ If a corrupted index cache is detected this function regenerates--- the index cache and then reattempt to read the index once (and--- 'die's if it fails again).-readIndexCache :: Verbosity -> Index -> IO Cache-readIndexCache verbosity index = do-    cacheOrFail <- readIndexCache' index-    case cacheOrFail of-      Left msg -> do-          warn verbosity $ concat-              [ "Parsing the index cache failed (", msg, "). "-              , "Trying to regenerate the index cache..."-              ]--          updatePackageIndexCacheFile verbosity index--          either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index--      Right res -> return (hashConsCache res)--readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache-readNoIndexCache verbosity index = do-    cacheOrFail <- readNoIndexCache' index-    case cacheOrFail of-      Left msg -> do-          warn verbosity $ concat-              [ "Parsing the index cache failed (", msg, "). "-              , "Trying to regenerate the index cache..."-              ]--          updatePackageIndexCacheFile verbosity index--          either (die' verbosity) return =<< readNoIndexCache' index--      -- we don't hash cons local repository cache, they are hopefully small-      Right res -> return res---- | Read the 'Index' cache from the filesystem without attempting to--- regenerate on parsing failures.-readIndexCache' :: Index -> IO (Either String Cache)-readIndexCache' index-  | is01Index index = structuredDecodeFileOrFail (cacheFile index)-  | otherwise       = liftM (Right .read00IndexCache) $-                      BSS.readFile (cacheFile index)--readNoIndexCache' :: Index -> IO (Either String NoIndexCache)-readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)---- | Write the 'Index' cache to the filesystem-writeIndexCache :: Index -> Cache -> IO ()-writeIndexCache index cache-  | is01Index index = structuredEncodeFile (cacheFile index) cache-  | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)--writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()-writeNoIndexCache verbosity index cache = do-    let path = cacheFile index-    createDirectoryIfMissingVerbose verbosity True (takeDirectory path)-    structuredEncodeFile path cache---- | Write the 'IndexState' to the filesystem-writeIndexTimestamp :: Index -> RepoIndexState -> IO ()-writeIndexTimestamp index st-  = writeFile (timestampFile index) (prettyShow st)---- | Read out the "current" index timestamp, i.e., what--- timestamp you would use to revert to this version-currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp-currentIndexTimestamp verbosity repoCtxt r = do-    mb_is <- readIndexTimestamp (RepoIndex repoCtxt r)-    case mb_is of-      Just (IndexStateTime ts) -> return ts-      _ -> do-        (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead-        return (isiHeadTime isi)---- | Read the 'IndexState' from the filesystem-readIndexTimestamp :: Index -> IO (Maybe RepoIndexState)-readIndexTimestamp index-  = fmap simpleParsec (readFile (timestampFile index))-        `catchIO` \e ->-            if isDoesNotExistError e-                then return Nothing-                else ioError e---- | Optimise sharing of equal values inside 'Cache'------ c.f. https://en.wikipedia.org/wiki/Hash_consing-hashConsCache :: Cache -> Cache-hashConsCache cache0-    = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) }-  where-    -- TODO/NOTE:-    ---    -- If/when we redo the binary serialisation via e.g. CBOR and we-    -- are able to use incremental decoding, we may want to move the-    -- hash-consing into the incremental deserialisation, or-    -- alterantively even do something like-    -- http://cbor.schmorp.de/value-sharing-    ---    go _ _ [] = []-    -- for now we only optimise only CachePackageIds since those-    -- represent the vast majority-    go !pns !pvs (CachePackageId pid bno ts : rest)-        = CachePackageId pid' bno ts : go pns' pvs' rest-      where-        !pid' = PackageIdentifier pn' pv'-        (!pn',!pns') = mapIntern pn pns-        (!pv',!pvs') = mapIntern pv pvs-        PackageIdentifier pn pv = pid--    go pns pvs (x:xs) = x : go pns pvs xs--    mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k)-    mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m)---- | Cabal caches various information about the Hackage index-data Cache = Cache-    { cacheHeadTs  :: Timestamp-      -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the-      -- invariant of 'cacheEntries' being in chronological order is-      -- violated, this corresponds to the last (seen) 'Timestamp' in-      -- 'cacheEntries'-    , cacheEntries :: [IndexCacheEntry]-    }-  deriving (Show, Generic)--instance NFData Cache where-    rnf = rnf . cacheEntries---- | Cache format for 'file+noindex' repositories-newtype NoIndexCache = NoIndexCache-    { noIndexCacheEntries :: [NoIndexCacheEntry]-    }-  deriving (Show, Generic)--instance NFData NoIndexCache where-    rnf = rnf . noIndexCacheEntries---- | Tar files are block structured with 512 byte blocks. Every header and file--- content starts on a block boundary.----type BlockNo = Word32 -- Tar.TarEntryOffset--data IndexCacheEntry-    = CachePackageId PackageId !BlockNo !Timestamp-    | CachePreference Dependency !BlockNo !Timestamp-    | CacheBuildTreeRef !BuildTreeRefType !BlockNo-      -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build-  deriving (Eq,Show,Generic)--data NoIndexCacheEntry-    = CacheGPD GenericPackageDescription !BSS.ByteString-  deriving (Eq,Show,Generic)--instance NFData IndexCacheEntry where-    rnf (CachePackageId pkgid _ _) = rnf pkgid-    rnf (CachePreference dep _ _) = rnf dep-    rnf (CacheBuildTreeRef _ _) = ()--instance NFData NoIndexCacheEntry where-    rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs--cacheEntryTimestamp :: IndexCacheEntry -> Timestamp-cacheEntryTimestamp (CacheBuildTreeRef _ _)  = nullTimestamp-cacheEntryTimestamp (CachePreference _ _ ts) = ts-cacheEntryTimestamp (CachePackageId _ _ ts)  = ts--------------------------------------------------------------------------------- new binary 01-index.cache format--instance Binary Cache-instance Binary IndexCacheEntry-instance Binary NoIndexCache--instance Structured Cache-instance Structured IndexCacheEntry-instance Structured NoIndexCache---- | We need to save only .cabal file contents-instance Binary NoIndexCacheEntry where-    put (CacheGPD _ bs) = put bs--    get = do-        bs <- get-        case parseGenericPackageDescriptionMaybe bs of-            Just gpd -> return (CacheGPD gpd bs)-            Nothing  -> fail "Failed to parse GPD"--instance Structured NoIndexCacheEntry where-    structure = nominalStructure--------------------------------------------------------------------------------- legacy 00-index.cache format--packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String-packageKey = "pkg:"-blocknoKey = "b#"-buildTreeRefKey     = "build-tree-ref:"-preferredVersionKey = "pref-ver:"---- legacy 00-index.cache format-read00IndexCache :: BSS.ByteString -> Cache-read00IndexCache bs = Cache-  { cacheHeadTs  = nullTimestamp-  , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs-  }--read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry-read00IndexCacheEntry = \line ->-  case BSS.words line of-    [key, pkgnamestr, pkgverstr, sep, blocknostr]-      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->-      case (parseName pkgnamestr, parseVer pkgverstr [],-            parseBlockNo blocknostr) of-        (Just pkgname, Just pkgver, Just blockno)-          -> Just (CachePackageId (PackageIdentifier pkgname pkgver)-                                  blockno nullTimestamp)-        _ -> Nothing-    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->-      case (parseRefType typecodestr, parseBlockNo blocknostr) of-        (Just refType, Just blockno)-          -> Just (CacheBuildTreeRef refType blockno)-        _ -> Nothing--    (key: remainder) | key == BSS.pack preferredVersionKey -> do-      pref <- simpleParsecBS (BSS.unwords remainder)-      return $ CachePreference pref 0 nullTimestamp--    _  -> Nothing-  where-    parseName str-      | BSS.all (\c -> isAlphaNum c || c == '-') str-                  = Just (mkPackageName (BSS.unpack str))-      | otherwise = Nothing--    parseVer str vs =-      case BSS.readInt str of-        Nothing        -> Nothing-        Just (v, str') -> case BSS.uncons str' of-          Just ('.', str'') -> parseVer str'' (v:vs)-          Just _            -> Nothing-          Nothing           -> Just (mkVersion (reverse (v:vs)))--    parseBlockNo str =-      case BSS.readInt str of-        Just (blockno, remainder)-          | BSS.null remainder -> Just (fromIntegral blockno)-        _                      -> Nothing--    parseRefType str =-      case BSS.uncons str of-        Just (typeCode, remainder)-          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode-            -> Just (refTypeFromTypeCode typeCode)-        _   -> Nothing---- legacy 00-index.cache format-show00IndexCache :: Cache -> String-show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries--show00IndexCacheEntry :: IndexCacheEntry -> String-show00IndexCacheEntry entry = unwords $ case entry of-    CachePackageId pkgid b _ ->-        [ packageKey-        , prettyShow (packageName pkgid)-        , prettyShow (packageVersion pkgid)-        , blocknoKey-        , show b-        ]-    CacheBuildTreeRef tr b ->-        [ buildTreeRefKey-        , [typeCodeFromRefType tr]-        , show b-        ]-    CachePreference dep _ _  ->-        [ preferredVersionKey-        , prettyShow dep-        ]
− Distribution/Client/IndexUtils/ActiveRepos.hs 
@@ -1,190 +0,0 @@-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Client.IndexUtils.ActiveRepos (-    ActiveRepos (..),-    defaultActiveRepos,-    filterSkippedActiveRepos,-    ActiveRepoEntry (..),-    CombineStrategy (..),-    organizeByRepos,-) where--import Distribution.Client.Compat.Prelude-import Distribution.Client.Types.RepoName (RepoName (..))-import Prelude ()--import Distribution.Parsec (parsecLeadingCommaNonEmpty)--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- $setup--- >>> import Distribution.Parsec------------------------------------------------------------------------------------ Types------------------------------------------------------------------------------------ | Ordered list of active repositories.-newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]-  deriving (Eq, Show, Generic)--defaultActiveRepos :: ActiveRepos-defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ]---- | Note, this does nothing if 'ActiveRepoRest' is present.-filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos-filterSkippedActiveRepos repos@(ActiveRepos entries)-    | any isActiveRepoRest entries = repos-    | otherwise                    = ActiveRepos (filter notSkipped entries)-  where-    isActiveRepoRest (ActiveRepoRest _) = True-    isActiveRepoRest _                  = False--    notSkipped (ActiveRepo _ CombineStrategySkip) = False-    notSkipped _                                  = True--instance Binary ActiveRepos-instance Structured ActiveRepos-instance NFData ActiveRepos--instance Pretty ActiveRepos where-    pretty (ActiveRepos [])-        = Disp.text ":none"-    pretty (ActiveRepos repos)-        = Disp.hsep-        $ Disp.punctuate Disp.comma-        $ map pretty repos---- | Note: empty string is not valid 'ActiveRepos'.------ >>> simpleParsec "" :: Maybe ActiveRepos--- Nothing------ >>> simpleParsec ":none" :: Maybe ActiveRepos--- Just (ActiveRepos [])------ >>> simpleParsec ":rest" :: Maybe ActiveRepos--- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge])------ >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos--- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])----instance Parsec ActiveRepos where-    parsec = ActiveRepos [] <$ P.try (P.string ":none")-        <|> do-            repos <- parsecLeadingCommaNonEmpty parsec-            return (ActiveRepos (toList repos))--data ActiveRepoEntry-    = ActiveRepoRest CombineStrategy        -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'-    | ActiveRepo RepoName CombineStrategy   -- ^ explicit repository name-  deriving (Eq, Show, Generic)--instance Binary ActiveRepoEntry-instance Structured ActiveRepoEntry-instance NFData ActiveRepoEntry--instance Pretty ActiveRepoEntry where-    pretty (ActiveRepoRest s) =-        Disp.text ":rest" <<>> Disp.colon <<>> pretty s-    pretty (ActiveRepo r s) =-        pretty r <<>> Disp.colon <<>> pretty s--instance Parsec ActiveRepoEntry where-    parsec = leadColon <|> leadRepo where-        leadColon = do-            _ <- P.char ':'-            token <- P.munch1 isAlpha-            case token of-                "rest" -> ActiveRepoRest <$> strategyP-                "repo" -> P.char ':' *> leadRepo-                _      -> P.unexpected $ "Unknown active repository entry type: " ++ token--        leadRepo = do-            r <- parsec-            s <- strategyP-            return (ActiveRepo r s)--        strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)--data CombineStrategy-    = CombineStrategySkip     -- ^ skip this repository-    | CombineStrategyMerge    -- ^ merge existing versions-    | CombineStrategyOverride -- ^ if later repository specifies a package,-                              --   all package versions are replaced-  deriving (Eq, Show, Enum, Bounded, Generic)--instance Binary CombineStrategy-instance Structured CombineStrategy-instance NFData CombineStrategy--instance Pretty CombineStrategy where-    pretty CombineStrategySkip     = Disp.text "skip"-    pretty CombineStrategyMerge    = Disp.text "merge"-    pretty CombineStrategyOverride = Disp.text "override"--instance Parsec CombineStrategy where-    parsec = P.choice-        [ CombineStrategySkip     <$ P.string "skip"-        , CombineStrategyMerge    <$ P.string "merge"-        , CombineStrategyOverride <$ P.string "override"-        ]------------------------------------------------------------------------------------ Organisation------------------------------------------------------------------------------------ | Sort values 'RepoName' according to 'ActiveRepos' list.------ >>> let repos = [RepoName "a", RepoName "b", RepoName "c"]--- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos--- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]------ >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos--- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]------ >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos--- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)]------ >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos--- Left "no repository provided d"------ Note: currently if 'ActiveRepoRest' is provided more than once,--- rest-repositories will be multiple times in the output.----organizeByRepos-    :: forall a. ActiveRepos-    -> (a -> RepoName)-    -> [a]-    -> Either String [(a, CombineStrategy)]-organizeByRepos (ActiveRepos xs0) sel ys0 =-    -- here we use lazyness to do only one traversal-    let (rest, result) = case go rest xs0 ys0 of-            Right (rest', result') -> (rest', Right result')-            Left err               -> ([],    Left err)-    in result-  where-    go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])-    go _rest []                      ys = Right (ys, [])-    go  rest (ActiveRepoRest s : xs) ys =-        go rest xs ys <&> \(rest', result) ->-           (rest', map (\x -> (x, s)) rest ++ result)-    go  rest (ActiveRepo r s : xs)   ys = do-        (z, zs) <- extract r ys-        go rest xs zs <&> \(rest', result) ->-            (rest', (z, s) : result)--    extract :: RepoName -> [a] -> Either String (a, [a])-    extract r = loop id where-        loop _acc []     = Left $ "no repository provided " ++ prettyShow r-        loop  acc (x:xs)-            | sel x == r = Right (x, acc xs)-            | otherwise  = loop (acc . (x :)) xs--    (<&>)-        :: Either err ([s], b)-        -> (([s], b) -> ([s], c))-        -> Either err ([s], c)-    (<&>) = flip fmap
− Distribution/Client/IndexUtils/IndexState.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.IndexUtils.IndexUtils--- Copyright   :  (c) 2016 Herbert Valerio Riedel--- License     :  BSD3------ Package repositories index state.----module Distribution.Client.IndexUtils.IndexState (-    RepoIndexState(..),-    TotalIndexState,-    headTotalIndexState,-    makeTotalIndexState,-    lookupIndexState,-    insertIndexState,-) where--import Distribution.Client.Compat.Prelude-import Distribution.Client.IndexUtils.Timestamp (Timestamp)-import Distribution.Client.Types.RepoName       (RepoName (..))--import Distribution.Parsec (parsecLeadingCommaNonEmpty)--import qualified Data.Map.Strict                 as Map-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- $setup--- >>> import Distribution.Parsec------------------------------------------------------------------------------------ Total index state------------------------------------------------------------------------------------ | Index state of multiple repositories-data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState)-  deriving (Eq, Show, Generic)--instance Binary TotalIndexState-instance Structured TotalIndexState-instance NFData TotalIndexState--instance Pretty TotalIndexState where-    pretty (TIS IndexStateHead m)-        | not (Map.null m)-        = Disp.hsep $ Disp.punctuate Disp.comma-            [ pretty rn Disp.<+> pretty idx-            | (rn, idx) <- Map.toList m-            ]-    pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where-        go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx---- |------ >>> simpleParsec "HEAD" :: Maybe TotalIndexState--- Just (TIS IndexStateHead (fromList []))------ >>> simpleParsec "" :: Maybe TotalIndexState--- Nothing------ >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState--- Just (TIS IndexStateHead (fromList []))------ >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState--- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)]))------ >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState--- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))]))----instance Parsec TotalIndexState where-    parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where-        single0 = startsWithRepoName <|> TokTimestamp <$> parsec-        startsWithRepoName = do-            reponame <- parsec-            -- the "HEAD" is technically a valid reponame...-            if reponame == RepoName "HEAD"-            then return TokHead-            else do-                P.spaces-                TokRepo reponame <$> parsec--        add :: TotalIndexState -> Tok -> TotalIndexState-        add _           TokHead           = headTotalIndexState-        add _           (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty-        add (TIS def m) (TokRepo rn idx)  = TIS def (Map.insert rn idx m)---- used in Parsec TotalIndexState implementation-data Tok-    = TokRepo RepoName RepoIndexState-    | TokTimestamp Timestamp-    | TokHead---- | Remove non-default values from 'TotalIndexState'.-normalise :: TotalIndexState -> TotalIndexState-normalise (TIS def m) = TIS def (Map.filter (/= def) m)---- | 'TotalIndexState' where all repositories are at @HEAD@ index state.-headTotalIndexState :: TotalIndexState-headTotalIndexState = TIS IndexStateHead Map.empty---- | Create 'TotalIndexState'.-makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState-makeTotalIndexState def m = normalise (TIS def m)---- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'.-lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState-lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m---- | Insert a 'RepoIndexState' to 'TotalIndexState'.-insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState-insertIndexState rn idx (TIS def m)-    | idx == def = TIS def (Map.delete rn m)-    | otherwise  = TIS def (Map.insert rn idx m)------------------------------------------------------------------------------------ Repository index state------------------------------------------------------------------------------------ | Specification of the state of a specific repo package index-data RepoIndexState-    = IndexStateHead -- ^ Use all available entries-    | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time-    deriving (Eq,Generic,Show)--instance Binary RepoIndexState-instance Structured RepoIndexState-instance NFData RepoIndexState--instance Pretty RepoIndexState where-    pretty IndexStateHead = Disp.text "HEAD"-    pretty (IndexStateTime ts) = pretty ts--instance Parsec RepoIndexState where-    parsec = parseHead <|> parseTime where-        parseHead = IndexStateHead <$ P.string "HEAD"-        parseTime = IndexStateTime <$> parsec
− Distribution/Client/IndexUtils/Timestamp.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.IndexUtils.Timestamp--- Copyright   :  (c) 2016 Herbert Valerio Riedel--- License     :  BSD3------ Timestamp type used in package indexes--module Distribution.Client.IndexUtils.Timestamp-    ( Timestamp-    , nullTimestamp-    , epochTimeToTimestamp-    , timestampToUTCTime-    , utcTimeToTimestamp-    , maximumTimestamp-    ) where--import Distribution.Client.Compat.Prelude---- read is needed for Text instance-import Prelude (read)--import Data.Time             (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)--import qualified Codec.Archive.Tar.Entry         as Tar-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).-newtype Timestamp = TS Int64 -- Tar.EpochTime-                  deriving (Eq,Ord,Enum,NFData,Show,Generic)--epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp-epochTimeToTimestamp et-  | ts == nullTimestamp  = Nothing-  | otherwise            = Just ts-  where-    ts = TS et--timestampToUTCTime :: Timestamp -> Maybe UTCTime-timestampToUTCTime (TS t)-  | t == minBound  = Nothing-  | otherwise      = Just $ posixSecondsToUTCTime (fromIntegral t)--utcTimeToTimestamp :: UTCTime -> Maybe Timestamp-utcTimeToTimestamp utct-  | minTime <= t, t <= maxTime  = Just (TS (fromIntegral t))-  | otherwise                   = Nothing-  where-    maxTime = toInteger (maxBound :: Int64)-    minTime = toInteger (succ minBound :: Int64)-    t :: Integer-    t = round . utcTimeToPOSIXSeconds $ utct---- | Compute the maximum 'Timestamp' value------ Returns 'nullTimestamp' for the empty list.  Also note that--- 'nullTimestamp' compares as smaller to all non-'nullTimestamp'--- values.-maximumTimestamp :: [Timestamp] -> Timestamp-maximumTimestamp [] = nullTimestamp-maximumTimestamp xs@(_:_) = maximum xs---- returns 'Nothing' if not representable as 'Timestamp'-posixSecondsToTimestamp :: Integer -> Maybe Timestamp-posixSecondsToTimestamp pt-  | minTs <= pt, pt <= maxTs  = Just (TS (fromInteger pt))-  | otherwise                 = Nothing-  where-    maxTs = toInteger (maxBound :: Int64)-    minTs = toInteger (succ minBound :: Int64)---- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format--- (e.g. @"2017-12-31T23:59:59Z"@)------ Returns empty string for 'nullTimestamp' in order for------ > null (display nullTimestamp) == True------ to hold.-showTimestamp :: Timestamp -> String-showTimestamp ts = case timestampToUTCTime ts of-    Nothing          -> ""-    -- Note: we don't use 'formatTime' here to avoid incurring a-    -- dependency on 'old-locale' for older `time` libs-    Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z"-  where-    showTOD = show . timeToTimeOfDay--instance Binary Timestamp-instance Structured Timestamp--instance Pretty Timestamp where-    pretty = Disp.text . showTimestamp--instance Parsec Timestamp where-    parsec = parsePosix <|> parseUTC-      where-        -- | Parses unix timestamps, e.g. @"\@1474626019"@-        parsePosix = do-            _ <- P.char '@'-            t <- P.integral -- note, no negative timestamps-            maybe (fail (show t ++ " is not representable as timestamp")) return $-                posixSecondsToTimestamp t--        -- | Parses ISO8601/RFC3339-style UTC timestamps,-        -- e.g. @"2017-12-31T23:59:59Z"@-        ---        -- TODO: support numeric tz offsets; allow to leave off seconds-        parseUTC = do-            -- Note: we don't use 'Data.Time.Format.parseTime' here since-            -- we want more control over the accepted formats.--            ye <- parseYear-            _ <- P.char '-'-            mo   <- parseTwoDigits-            _ <- P.char '-'-            da   <- parseTwoDigits-            _ <- P.char 'T'--            utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $-                       fromGregorianValid ye mo da--            ho   <- parseTwoDigits-            _ <- P.char ':'-            mi   <- parseTwoDigits-            _ <- P.char ':'-            se   <- parseTwoDigits-            _ <- P.char 'Z'--            utctDayTime <- maybe (fail (show (ho,mi,se) ++  " is not valid time of day")) (return . timeOfDayToTime) $-                           makeTimeOfDayValid ho mi (realToFrac (se::Int))--            let utc = UTCTime {..}--            maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc--        parseTwoDigits = do-            d1 <- P.satisfy isDigit-            d2 <- P.satisfy isDigit-            return (read [d1,d2])--        -- A year must have at least 4 digits; e.g. "0097" is fine,-        -- while "97" is not c.f. RFC3339 which-        -- deprecates 2-digit years-        parseYear = do-            sign <- P.option ' ' (P.char '-')-            ds <- P.munch1 isDigit-            when (length ds < 4) $ fail "Year should have at least 4 digits"-            return (read (sign:ds))---- | Special timestamp value to be used when 'timestamp' is--- missing/unknown/invalid-nullTimestamp :: Timestamp-nullTimestamp = TS minBound
− Distribution/Client/Init.hs 
@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Implementation of the 'cabal init' command, which creates an initial .cabal--- file for a project.-----------------------------------------------------------------------------------module Distribution.Client.Init (--    -- * Commands-    initCabal-  , incVersion--  ) where--import Distribution.Client.Init.Command-  ( initCabal, incVersion )
− Distribution/Client/Init/Command.hs 
@@ -1,730 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Command--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Implementation of the 'cabal init' command, which creates an initial .cabal--- file for a project.-----------------------------------------------------------------------------------module Distribution.Client.Init.Command (--    -- * Commands-    initCabal-  , incVersion--  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)--import System.IO-  ( hSetBuffering, stdout, BufferMode(..) )-import System.Directory-  ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents )-import System.FilePath-  ( (</>), takeBaseName, equalFilePath )--import qualified Data.List.NonEmpty as NE-import qualified Data.Map as M-import Control.Monad-  ( (>=>) )-import Control.Arrow-  ( (&&&), (***) )--import Distribution.CabalSpecVersion-  ( CabalSpecVersion (..), showCabalSpecVersion )-import Distribution.Version-  ( Version, mkVersion, alterVersion, majorBoundVersion-  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )-import Distribution.ModuleName-  ( ModuleName )  -- And for the Text instance-import Distribution.InstalledPackageInfo-  ( InstalledPackageInfo, exposed )-import qualified Distribution.Package as P-import qualified Distribution.SPDX as SPDX-import Language.Haskell.Extension ( Language(..) )--import Distribution.Client.Init.Defaults-  ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir )-import Distribution.Client.Init.FileCreators-  ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs-  , createTestSuiteIfEligible, writeCabalFile )-import Distribution.Client.Init.Prompt-  ( prompt, promptYesNo, promptStr, promptList, maybePrompt-  , promptListOptional )-import Distribution.Client.Init.Utils-  ( eligibleForTestSuite,  message )-import Distribution.Client.Init.Types-  ( InitFlags(..), PackageType(..), Category(..)-  , displayPackageType )-import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,-    SourceFileEntry(..),-    scanForModules, neededBuildPrograms )--import Distribution.Simple.Flag-  ( maybeToFlag )-import Distribution.Simple.Setup-  ( Flag(..), flagToMaybe )-import Distribution.Simple.Configure-  ( getInstalledPackages )-import Distribution.Simple.Compiler-  ( PackageDBStack, Compiler )-import Distribution.Simple.Program-  ( ProgramDb )-import Distribution.Simple.PackageIndex-  ( InstalledPackageIndex, moduleNameIndex )--import Distribution.Solver.Types.PackageIndex-  ( elemByPackageName )--import Distribution.Client.IndexUtils-  ( getSourcePackages )-import Distribution.Client.Types-  ( SourcePackageDb(..) )-import Distribution.Client.Setup-  ( RepoContext(..) )--initCabal :: Verbosity-          -> PackageDBStack-          -> RepoContext-          -> Compiler-          -> ProgramDb-          -> InitFlags-          -> IO ()-initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do--  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-  sourcePkgDb <- getSourcePackages verbosity repoCtxt--  hSetBuffering stdout NoBuffering--  initFlags' <- extendFlags installedPkgIndex sourcePkgDb initFlags--  case license initFlags' of-    Flag SPDX.NONE -> return ()-    _              -> writeLicense initFlags'-  writeChangeLog initFlags'-  createDirectories (sourceDirs initFlags')-  createLibHs initFlags'-  createDirectories (applicationDirs initFlags')-  createMainHs initFlags'-  createTestSuiteIfEligible initFlags'-  success <- writeCabalFile initFlags'--  when success $ generateWarnings initFlags'--------------------------------------------------------------------------------  Flag acquisition  ------------------------------------------------------------------------------------------------------------------------------------- | Fill in more details in InitFlags by guessing, discovering, or prompting--- the user.-extendFlags :: InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags-extendFlags pkgIx sourcePkgDb =-      getSimpleProject-  >=> getLibOrExec-  >=> getCabalVersion-  >=> getPackageName sourcePkgDb-  >=> getVersion-  >=> getLicense-  >=> getAuthorInfo-  >=> getHomepage-  >=> getSynopsis-  >=> getCategory-  >=> getExtraSourceFiles-  >=> getAppDir-  >=> getSrcDir-  >=> getGenTests-  >=> getTestDir-  >=> getLanguage-  >=> getGenComments-  >=> getModulesBuildToolsAndDeps pkgIx---- | Combine two actions which may return a value, preferring the first. That---   is, run the second action only if the first doesn't return a value.-infixr 1 ?>>-(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)-f ?>> g = do-  ma <- f-  if isJust ma-    then return ma-    else g---- | Ask if a simple project with sensible defaults should be created.-getSimpleProject :: InitFlags -> IO InitFlags-getSimpleProject flags = do-  simpleProj <-     return (flagToMaybe $ simpleProject flags)-                ?>> maybePrompt flags-                    (promptYesNo-                      "Should I generate a simple project with sensible defaults"-                      (Just True))-  return $ case maybeToFlag simpleProj of-    Flag True ->-      flags { interactive = Flag False-            , simpleProject = Flag True-            , packageType = Flag LibraryAndExecutable-            , cabalVersion = Flag defaultCabalVersion-            }-    simpleProjFlag@_ ->-      flags { simpleProject = simpleProjFlag }----- | Get the version of the cabal spec to use.------ The spec version can be specified by the InitFlags cabalVersion field. If--- none is specified then the user is prompted to pick from a list of--- supported versions (see code below).-getCabalVersion :: InitFlags -> IO InitFlags-getCabalVersion flags = do-  cabVer <-     return (flagToMaybe $ cabalVersion flags)-            ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`-                                  promptList "Please choose version of the Cabal specification to use"-                                  [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0]-                                  (Just defaultCabalVersion) displayCabalVersion False)-            ?>> return (Just defaultCabalVersion)--  return $  flags { cabalVersion = maybeToFlag cabVer }--  where-    displayCabalVersion :: CabalSpecVersion -> String-    displayCabalVersion v = case v of-      CabalSpecV1_10 -> "1.10   (legacy)"-      CabalSpecV2_0  -> "2.0    (+ support for Backpack, internal sub-libs, '^>=' operator)"-      CabalSpecV2_2  -> "2.2    (+ support for 'common', 'elif', redundant commas, SPDX)"-      CabalSpecV2_4  -> "2.4    (+ support for '**' globbing)"-      CabalSpecV3_0  -> "3.0    (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"-      _              -> showCabalSpecVersion v------ | Get the package name: use the package directory (supplied, or the current---   directory by default) as a guess. It looks at the SourcePackageDb to avoid---   using an existing package name.-getPackageName :: SourcePackageDb -> InitFlags -> IO InitFlags-getPackageName sourcePkgDb flags = do-  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)-              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)--  let guess' | isPkgRegistered guess = Nothing-             | otherwise = guess--  pkgName' <-     return (flagToMaybe $ packageName flags)-              ?>> maybePrompt flags (prompt "Package name" guess')-              ?>> return guess'--  chooseAgain <- if isPkgRegistered pkgName'-                    then promptYesNo promptOtherNameMsg (Just True)-                    else return False--  if chooseAgain-    then getPackageName sourcePkgDb flags-    else return $ flags { packageName = maybeToFlag pkgName' }--  where-    isPkgRegistered (Just pkg) = elemByPackageName (packageIndex sourcePkgDb) pkg-    isPkgRegistered Nothing    = False--    promptOtherNameMsg = "This package name is already used by another " ++-                         "package on hackage. Do you want to choose a " ++-                         "different name"---- | Package version: use 0.1.0.0 as a last resort, but try prompting the user---  if possible.-getVersion :: InitFlags -> IO InitFlags-getVersion flags = do-  let v = Just $ mkVersion [0,1,0,0]-  v' <-     return (flagToMaybe $ version flags)-        ?>> maybePrompt flags (prompt "Package version" v)-        ?>> return v-  return $ flags { version = maybeToFlag v' }---- | Choose a license for the package.------ The license can come from Initflags (license field), if it is not present--- then prompt the user from a predefined list of licenses.-getLicense :: InitFlags -> IO InitFlags-getLicense flags = do-  elic <- return (fmap Right $ flagToMaybe $ license flags)-      ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True)--  case elic of-      Nothing          -> return flags { license = NoFlag }-      Just (Right lic) -> return flags { license = Flag lic }-      Just (Left str)  -> case eitherParsec str of-          Right lic -> return flags { license = Flag lic }-          -- on error, loop-          Left err -> do-              putStrLn "The license must be a valid SPDX expression."-              putStrLn err-              getLicense flags-  where-    -- perfectly we'll have this and writeLicense (in FileCreators)-    -- in a single file-    listedLicenses =-      SPDX.NONE :-      map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))-      [ SPDX.BSD_2_Clause-      , SPDX.BSD_3_Clause-      , SPDX.Apache_2_0-      , SPDX.MIT-      , SPDX.MPL_2_0-      , SPDX.ISC--      , SPDX.GPL_2_0_only-      , SPDX.GPL_3_0_only-      , SPDX.LGPL_2_1_only-      , SPDX.LGPL_3_0_only-      , SPDX.AGPL_3_0_only--      , SPDX.GPL_2_0_or_later-      , SPDX.GPL_3_0_or_later-      , SPDX.LGPL_2_1_or_later-      , SPDX.LGPL_3_0_or_later-      , SPDX.AGPL_3_0_or_later-      ]---- | The author's name and email. Prompt, or try to guess from an existing---   darcs repo.-getAuthorInfo :: InitFlags -> IO InitFlags-getAuthorInfo flags = do-  (authorName, authorEmail)  <--    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail-  authorName'  <-     return (flagToMaybe $ author flags)-                  ?>> maybePrompt flags (promptStr "Author name" authorName)-                  ?>> return authorName--  authorEmail' <-     return (flagToMaybe $ email flags)-                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)-                  ?>> return authorEmail--  return $ flags { author = maybeToFlag authorName'-                 , email  = maybeToFlag authorEmail'-                 }---- | Prompt for a homepage URL for the package.-getHomepage :: InitFlags -> IO InitFlags-getHomepage flags = do-  hp  <- queryHomepage-  hp' <-     return (flagToMaybe $ homepage flags)-         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)-         ?>> return hp--  return $ flags { homepage = maybeToFlag hp' }---- | Right now this does nothing, but it could be changed to do some---   intelligent guessing.-queryHomepage :: IO (Maybe String)-queryHomepage = return Nothing     -- get default remote darcs repo?---- | Prompt for a project synopsis.-getSynopsis :: InitFlags -> IO InitFlags-getSynopsis flags = do-  syn <-     return (flagToMaybe $ synopsis flags)-         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)--  return $ flags { synopsis = maybeToFlag syn }---- | Prompt for a package category.---   Note that it should be possible to do some smarter guessing here too, i.e.---   look at the name of the top level source directory.-getCategory :: InitFlags -> IO InitFlags-getCategory flags = do-  cat <-     return (flagToMaybe $ category flags)-         ?>> fmap join (maybePrompt flags-                         (promptListOptional "Project category" [Codec ..]))-  return $ flags { category = maybeToFlag cat }---- | Try to guess extra source files (don't prompt the user).-getExtraSourceFiles :: InitFlags -> IO InitFlags-getExtraSourceFiles flags = do-  extraSrcFiles <-     return (extraSrc flags)-                   ?>> Just `fmap` guessExtraSourceFiles flags--  return $ flags { extraSrc = extraSrcFiles }--defaultChangeLog :: FilePath-defaultChangeLog = "CHANGELOG.md"---- | Try to guess things to include in the extra-source-files field.---   For now, we just look for things in the root directory named---   'readme', 'changes', or 'changelog', with any sort of---   capitalization and any extension.-guessExtraSourceFiles :: InitFlags -> IO [FilePath]-guessExtraSourceFiles flags = do-  dir <--    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  files <- getDirectoryContents dir-  let extraFiles = filter isExtra files-  if any isLikeChangeLog extraFiles-    then return extraFiles-    else return (defaultChangeLog : extraFiles)--  where-    isExtra = likeFileNameBase ("README" : changeLogLikeBases)-    isLikeChangeLog = likeFileNameBase changeLogLikeBases-    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName-    changeLogLikeBases = ["CHANGES", "CHANGELOG"]---- | Ask whether the project builds a library or executable.-getLibOrExec :: InitFlags -> IO InitFlags-getLibOrExec flags = do-  pkgType <-     return (flagToMaybe $ packageType flags)-           ?>> maybePrompt flags (either (const Executable) id `fmap`-                                   promptList "What does the package build"-                                   [Executable, Library, LibraryAndExecutable]-                                   Nothing displayPackageType False)-           ?>> return (Just Executable)--  -- If this package contains an executable, get the main file name.-  mainFile <- if pkgType == Just Library then return Nothing else-                    getMainFile flags--  return $ flags { packageType = maybeToFlag pkgType-                 , 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, but will be created)") 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 if a test suite should be generated for the library.-getGenTests :: InitFlags -> IO InitFlags-getGenTests flags = do-  genTests <-     return (flagToMaybe $ initializeTestSuite flags)-                  -- Only generate a test suite if the package contains a library.-              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing-              ?>> maybePrompt flags-                  (promptYesNo-                    "Should I generate a test suite for the library"-                    (Just True))-  return $ flags { initializeTestSuite = maybeToFlag genTests }---- | Ask for the test suite root directory.-getTestDir :: InitFlags -> IO InitFlags-getTestDir flags = do-  dirs <- return (testDirs flags)-              -- Only need testDirs when test suite generation is enabled.-          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing-          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt-                   flags-                   (promptList "Test directory" ["test"] (Just "test") id True))--  return $ flags { testDirs = dirs }---- | Ask for the Haskell base language of the package.-getLanguage :: InitFlags -> IO InitFlags-getLanguage flags = do-  lang <-     return (flagToMaybe $ language flags)-          ?>> maybePrompt flags-                (either UnknownLanguage id `fmap`-                  promptList "What base language is the package written in"-                  [Haskell2010, Haskell98]-                  (Just Haskell2010) prettyShow True)-          ?>> return (Just Haskell2010)--  if invalidLanguage lang-    then putStrLn invalidOtherLanguageMsg >> getLanguage flags-    else return $ flags { language = maybeToFlag lang }--  where-    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t-    invalidLanguage _ = False--    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++-                              "Please enter a different language."---- | Ask whether to generate explanatory comments.-getGenComments :: InitFlags -> IO InitFlags-getGenComments flags = do-  genComments <-     return (not <$> flagToMaybe (noComments flags))-                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))-                 ?>> return (Just False)-  return $ flags { noComments = maybeToFlag (fmap not genComments) }-  where-    promptMsg = "Add informative comments to each field in the cabal file (y/n)"---- | Ask for the application root directory.-getAppDir :: InitFlags -> IO InitFlags-getAppDir flags = do-  appDirs <--    return (applicationDirs flags)-    ?>> noAppDirIfLibraryOnly-    ?>> guessAppDir flags-    ?>> promptUserForApplicationDir-    ?>> setDefault-  return $ flags { applicationDirs = appDirs }--  where-    -- If the packageType==Library, then there is no application dir.-    noAppDirIfLibraryOnly :: IO (Maybe [String])-    noAppDirIfLibraryOnly =-      if (packageType flags) == Flag Library-      then return (Just [])-      else return Nothing--    -- Set the default application directory.-    setDefault :: IO (Maybe [String])-    setDefault = pure (Just [defaultApplicationDir])--    -- Prompt the user for the application directory (defaulting to "app").-    -- Returns 'Nothing' if in non-interactive mode, otherwise will always-    -- return a 'Just' value ('Just []' if no separate application directory).-    promptUserForApplicationDir :: IO (Maybe [String])-    promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt-      flags-      (promptList-       ("Application " ++ mainFile ++ "directory")-       [[defaultApplicationDir], ["src-exe"], []]-        (Just [defaultApplicationDir])-       showOption True)--    showOption :: [String] -> String-    showOption [] = "(none)"-    showOption (x:_) = x--    -- The name-    mainFile :: String-    mainFile = case mainIs flags of-      Flag mainPath -> "(" ++ mainPath ++ ") "-      _             -> ""---- | Try to guess app directory. Could try harder; for the---   moment just looks to see whether there is a directory called 'app'.-guessAppDir :: InitFlags -> IO (Maybe [String])-guessAppDir flags = do-  dir      <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  appIsDir <- doesDirectoryExist (dir </> "app")-  return $ if appIsDir-             then Just ["app"]-             else Nothing---- | Ask for the source (library) root directory.-getSrcDir :: InitFlags -> IO InitFlags-getSrcDir flags = do-  srcDirs <--    return (sourceDirs flags)-    ?>> noSourceDirIfExecutableOnly-    ?>> guessSourceDir flags-    ?>> promptUserForSourceDir-    ?>> setDefault--  return $ flags { sourceDirs = srcDirs }--  where-    -- If the packageType==Executable, then there is no source dir.-    noSourceDirIfExecutableOnly :: IO (Maybe [String])-    noSourceDirIfExecutableOnly =-      if (packageType flags) == Flag Executable-      then return (Just [])-      else return Nothing--    -- Set the default source directory.-    setDefault :: IO (Maybe [String])-    setDefault = pure (Just [defaultSourceDir])--    -- Prompt the user for the source directory (defaulting to "app").-    -- Returns 'Nothing' if in non-interactive mode, otherwise will always-    -- return a 'Just' value ('Just []' if no separate application directory).-    promptUserForSourceDir :: IO (Maybe [String])-    promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt-      flags-      (promptList-       ("Library source directory")-       [[defaultSourceDir], ["lib"], ["src-lib"], []]-        (Just [defaultSourceDir])-       showOption True)--    showOption :: [String] -> String-    showOption [] = "(none)"-    showOption (x:_) = x----- | Try to guess source directory. Could try harder; for the---   moment just looks to see whether there is a directory called 'src'.-guessSourceDir :: InitFlags -> IO (Maybe [String])-guessSourceDir flags = do-  dir      <--    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags-  srcIsDir <- doesDirectoryExist (dir </> "src")-  return $ if srcIsDir-             then Just ["src"]-             else Nothing---- | Check whether a potential source file is located in one of the---   source directories.-isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool-isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf-isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs---- | Get the list of exposed modules and extra tools needed to build them.-getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags-getModulesBuildToolsAndDeps pkgIx flags = do-  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags--  sourceFiles0 <- scanForModules dir--  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0--  Just mods <-      return (exposedModules flags)-           ?>> (return . Just . map moduleName $ sourceFiles)--  tools <-     return (buildTools flags)-           ?>> (return . Just . neededBuildPrograms $ sourceFiles)--  deps <-      return (dependencies flags)-           ?>> Just <$> importsToDeps flags-                        (fromString "Prelude" :  -- to ensure we get base as a dep-                           (   nub   -- only need to consider each imported package once-                             . filter (`notElem` mods)  -- don't consider modules from-                                                        -- this package itself-                             . concatMap imports-                             $ sourceFiles-                           )-                        )-                        pkgIx--  exts <-     return (otherExts flags)-          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)--  -- If we're initializing a library and there were no modules discovered-  -- then create an empty 'MyLib' module.-  -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because-  -- then the executable needs to set 'other-modules: MyLib' or else the build-  -- fails.-  let (finalModsList, otherMods) = case (packageType flags, mods) of--        -- For an executable leave things as they are.-        (Flag Executable, _) -> (mods, otherModules flags)--        -- If a non-empty module list exists don't change anything.-        (_, (_:_)) -> (mods, otherModules flags)--        -- Library only: 'MyLib' in 'other-modules' only.-        (Flag Library, _) -> ([myLibModule], Nothing)--        -- For a 'LibraryAndExecutable' we need to have special handling.-        -- If we don't have a module list (Nothing or empty), then create a Lib.-        (_, []) ->-          if sourceDirs flags == applicationDirs flags-          then ([myLibModule], Just [myLibModule])-          else ([myLibModule], Nothing)--  return $ flags { exposedModules = Just finalModsList-                 , otherModules   = otherMods-                 , buildTools     = tools-                 , dependencies   = deps-                 , otherExts      = exts-                 }---- | Given a list of imported modules, retrieve the list of dependencies that--- provide those modules.-importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]-importsToDeps flags mods pkgIx = do--  let modMap :: M.Map ModuleName [InstalledPackageInfo]-      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx--      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]-      modDeps = map (id &&& flip M.lookup modMap) mods--  message flags "\nGuessing dependencies..."-  nub . catMaybes <$> traverse (chooseDep flags) modDeps---- Given a module and a list of installed packages providing it,--- choose a dependency (i.e. package + version range) to use for that--- module.-chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])-          -> IO (Maybe P.Dependency)--chooseDep flags (m, Nothing)-  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")-    >> return Nothing--chooseDep flags (m, Just [])-  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")-    >> return Nothing--    -- We found some packages: group them by name.-chooseDep flags (m, Just ps)-  = case pkgGroups of-      -- if there's only one group, i.e. multiple versions of a single package,-      -- we make it into a dependency, choosing the latest-ish version (see toDep).-      [grp] -> Just <$> toDep grp-      -- otherwise, we refuse to choose between different packages and make the user-      -- do it.-      grps  -> do message flags ("\nWarning: multiple packages found providing "-                                 ++ prettyShow m-                                 ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))-                  message flags "You will need to pick one and manually add it to the Build-depends: field."-                  return Nothing-  where-    pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)--    desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags)--    -- Given a list of available versions of the same package, pick a dependency.-    toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency--    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*-    toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries--    -- Otherwise, choose the latest version and issue a warning.-    toDep pids  = do-      message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")-      return $ P.Dependency (P.pkgName . NE.head $ pids)-                            (pvpize desugar . maximum . fmap P.pkgVersion $ pids)-                            P.mainLibSet --TODO take into account sublibraries---- | Given a version, return an API-compatible (according to PVP) version range.------ If the boolean argument denotes whether to use a desugared--- representation (if 'True') or the new-style @^>=@-form (if--- 'False').------ Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the--- same as @0.4.*@).-pvpize :: Bool -> Version -> VersionRange-pvpize False  v = majorBoundVersion v-pvpize True   v = orLaterVersion v'-           `intersectVersionRanges`-           earlierVersion (incVersion 1 v')-  where v' = alterVersion (take 2) v---- | Increment the nth version component (counting from 0).-incVersion :: Int -> Version -> Version-incVersion n = alterVersion (incVersion' n)-  where-    incVersion' 0 []     = [1]-    incVersion' 0 (v:_)  = [v+1]-    incVersion' m []     = replicate m 0 ++ [1]-    incVersion' m (v:vs) = v : incVersion' (m-1) vs---- | Generate warnings for missing fields etc.-generateWarnings :: InitFlags -> IO ()-generateWarnings flags = do-  message flags ""-  when (synopsis flags `elem` [NoFlag, Flag ""])-       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")--  message flags "You may want to edit the .cabal file and add a Description field."
− Distribution/Client/Init/Defaults.hs 
@@ -1,41 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Defaults--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Default values to use in cabal init (if not specified in config/flags).-----------------------------------------------------------------------------------module Distribution.Client.Init.Defaults (-    defaultApplicationDir-  , defaultSourceDir-  , defaultCabalVersion-  , myLibModule-  ) where--import Prelude (String)--import Distribution.ModuleName-  ( ModuleName )  -- And for the Text instance-import qualified Distribution.ModuleName as ModuleName-  ( fromString )-import Distribution.CabalSpecVersion-  ( CabalSpecVersion (..))--defaultApplicationDir :: String-defaultApplicationDir = "app"--defaultSourceDir :: String-defaultSourceDir = "src"--defaultCabalVersion :: CabalSpecVersion-defaultCabalVersion = CabalSpecV2_4--myLibModule :: ModuleName-myLibModule = ModuleName.fromString "MyLib"
− Distribution/Client/Init/FileCreators.hs 
@@ -1,650 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.FileCreators--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Functions to create files during 'cabal init'.-----------------------------------------------------------------------------------module Distribution.Client.Init.FileCreators (--    -- * Commands-    writeLicense-  , writeChangeLog-  , createDirectories-  , createLibHs-  , createMainHs-  , createTestSuiteIfEligible-  , writeCabalFile--  -- * For testing-  , generateCabalFile-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)--import System.FilePath-  ( (</>), (<.>), takeExtension )--import Distribution.Types.Dependency-import Distribution.Types.VersionRange--import Data.Time-  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )-import System.Directory-  ( getCurrentDirectory, doesFileExist, copyFile-  , createDirectoryIfMissing )--import Text.PrettyPrint hiding ((<>), mode, cat)--import Distribution.Client.Init.Defaults-  ( defaultCabalVersion, myLibModule )-import Distribution.Client.Init.Licenses-  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )-import Distribution.Client.Init.Utils-  ( eligibleForTestSuite, message )-import Distribution.Client.Init.Types-  ( InitFlags(..), BuildType(..), PackageType(..) )--import Distribution.CabalSpecVersion-import Distribution.Compat.Newtype-  ( Newtype )-import Distribution.Fields.Field-  ( FieldName )-import Distribution.License-  ( licenseFromSPDX )-import qualified Distribution.ModuleName as ModuleName-  ( toFilePath )-import Distribution.FieldGrammar.Newtypes-  ( SpecVersion(..) )-import Distribution.PackageDescription.FieldGrammar-  ( formatDependencyList, formatExposedModules, formatHsSourceDirs,-    formatOtherExtensions, formatOtherModules, formatExtraSourceFiles )-import Distribution.Simple.Flag-  ( maybeToFlag )-import Distribution.Simple.Setup-  ( Flag(..), flagToMaybe )-import Distribution.Simple.Utils-  ( toUTF8BS )-import Distribution.Fields.Pretty-  ( PrettyField(..), showFields' )--import qualified Distribution.SPDX as SPDX---------------------------------------------------------------------------------  File generation  -------------------------------------------------------------------------------------------------------------------------------------- | Write the LICENSE file, as specified in the InitFlags license field.------ For licences that contain the author's name(s), the values are taken--- from the 'authors' field of 'InitFlags', and if not specified will--- be the string "???".------ If the license type is unknown no license file will be created and--- a warning will be raised.-writeLicense :: InitFlags -> IO ()-writeLicense flags = do-  message flags "\nGenerating LICENSE..."-  year <- show <$> getCurrentYear-  let authors = fromMaybe "???" . flagToMaybe . author $ flags-  let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId-      isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid-      isSimpleLicense _                                                            = Nothing-  let licenseFile =-        case flagToMaybe (license flags) >>= isSimpleLicense of-          Just SPDX.BSD_2_Clause  -> Just $ bsd2 authors year-          Just SPDX.BSD_3_Clause  -> Just $ bsd3 authors year-          Just SPDX.Apache_2_0    -> Just apache20-          Just SPDX.MIT           -> Just $ mit authors year-          Just SPDX.MPL_2_0       -> Just mpl20-          Just SPDX.ISC           -> Just $ isc authors year--          -- GNU license come in "only" and "or-later" flavours-          -- license file used are the same.-          Just SPDX.GPL_2_0_only  -> Just gplv2-          Just SPDX.GPL_3_0_only  -> Just gplv3-          Just SPDX.LGPL_2_1_only -> Just lgpl21-          Just SPDX.LGPL_3_0_only -> Just lgpl3-          Just SPDX.AGPL_3_0_only -> Just agplv3--          Just SPDX.GPL_2_0_or_later  -> Just gplv2-          Just SPDX.GPL_3_0_or_later  -> Just gplv3-          Just SPDX.LGPL_2_1_or_later -> Just lgpl21-          Just SPDX.LGPL_3_0_or_later -> Just lgpl3-          Just SPDX.AGPL_3_0_or_later -> Just agplv3--          _ -> Nothing--  case licenseFile of-    Just licenseText -> writeFileSafe flags "LICENSE" licenseText-    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."---- | Returns the current calendar year.-getCurrentYear :: IO Integer-getCurrentYear = do-  u <- getCurrentTime-  z <- getCurrentTimeZone-  let l = utcToLocalTime z u-      (y, _, _) = toGregorian $ localDay l-  return y--defaultChangeLog :: FilePath-defaultChangeLog = "CHANGELOG.md"---- | Writes the changelog to the current directory.-writeChangeLog :: InitFlags -> IO ()-writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do-  message flags ("Generating "++ defaultChangeLog ++"...")-  writeFileSafe flags defaultChangeLog changeLog- where-  changeLog = unlines-    [ "# Revision history for " ++ pname-    , ""-    , "## " ++ pver ++ " -- YYYY-mm-dd"-    , ""-    , "* First version. Released on an unsuspecting world."-    ]-  pname = maybe "" prettyShow $ flagToMaybe $ packageName flags-  pver = maybe "" prettyShow $ flagToMaybe $ version flags---- | Creates and writes the initialized .cabal file.------ Returns @False@ if no package name is specified, @True@ otherwise.-writeCabalFile :: InitFlags -> IO Bool-writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do-  message flags "Error: no package name provided."-  return False-writeCabalFile flags@(InitFlags{packageName = Flag p}) = do-  let cabalFileName = prettyShow p ++ ".cabal"-  message flags $ "Generating " ++ cabalFileName ++ "..."-  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)-  return True---- | Write a file \"safely\", backing up any existing version (unless---   the overwrite flag is set).-writeFileSafe :: InitFlags -> FilePath -> String -> IO ()-writeFileSafe flags fileName content = do-  moveExistingFile flags fileName-  writeFile fileName content---- | Create directories, if they were given, and don't already exist.-createDirectories :: Maybe [String] -> IO ()-createDirectories mdirs = case mdirs of-  Just dirs -> for_ dirs (createDirectoryIfMissing True)-  Nothing   -> return ()---- | Create MyLib.hs file, if its the only module in the liste.-createLibHs :: InitFlags -> IO ()-createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do-  let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"-  case sourceDirs flags of-    Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)-    _                -> writeLibHs flags modFilePath---- | Write a MyLib.hs file if it doesn't already exist.-writeLibHs :: InitFlags -> FilePath -> IO ()-writeLibHs flags libPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let libFullPath = dir </> libPath-  exists <- doesFileExist libFullPath-  unless exists $ do-    message flags $ "Generating " ++ libPath ++ "..."-    writeFileSafe flags libFullPath myLibHs---- | Default MyLib.hs file.  Used when no Lib.hs exists.-myLibHs :: String-myLibHs = unlines-  [ "module MyLib (someFunc) where"-  , ""-  , "someFunc :: IO ()"-  , "someFunc = putStrLn \"someFunc\""-  ]---- | Create Main.hs, but only if we are init'ing an executable and---   the mainIs flag has been provided.-createMainHs :: InitFlags -> IO ()-createMainHs flags =-  if hasMainHs flags then-    case applicationDirs flags of-      Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)-      _ -> writeMainHs flags mainFile-  else return ()-  where-    mainFile = case mainIs flags of-      Flag x -> x-      NoFlag -> error "createMainHs: no mainIs"---- | Write a main file if it doesn't already exist.-writeMainHs :: InitFlags -> FilePath -> IO ()-writeMainHs flags mainPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let mainFullPath = dir </> mainPath-  exists <- doesFileExist mainFullPath-  unless exists $ do-      message flags $ "Generating " ++ mainPath ++ "..."-      writeFileSafe flags mainFullPath (mainHs flags)---- | Returns true if a main file exists.-hasMainHs :: InitFlags -> Bool-hasMainHs flags = case mainIs flags of-  Flag _ -> (packageType flags == Flag Executable-             || packageType flags == Flag LibraryAndExecutable)-  _ -> False---- | Default Main.(l)hs file.  Used when no Main.(l)hs exists.------   If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.-mainHs :: InitFlags -> String-mainHs flags = (unlines . map prependPrefix) $ case packageType flags of-  Flag LibraryAndExecutable ->-    [ "module Main where"-    , ""-    , "import qualified MyLib (someFunc)"-    , ""-    , "main :: IO ()"-    , "main = do"-    , "  putStrLn \"Hello, Haskell!\""-    , "  MyLib.someFunc"-    ]-  _ ->-    [ "module Main where"-    , ""-    , "main :: IO ()"-    , "main = putStrLn \"Hello, Haskell!\""-    ]-  where-    prependPrefix :: String -> String-    prependPrefix "" = ""-    prependPrefix line-      | isLiterate = "> " ++ line-      | otherwise  = line-    isLiterate = case mainIs flags of-      Flag mainPath -> takeExtension mainPath == ".lhs"-      _             -> False---- | Create a test suite for the package if eligible.-createTestSuiteIfEligible :: InitFlags -> IO ()-createTestSuiteIfEligible flags =-  when (eligibleForTestSuite flags) $ do-    createDirectories (testDirs flags)-    createTestHs flags---- | The name of the test file to generate (if --tests is specified).-testFile :: String-testFile = "MyLibTest.hs"---- | Create MyLibTest.hs, but only if we are init'ing a library and---   the initializeTestSuite flag has been set.------ It is up to the caller to verify that the package is eligible--- for test suite initialization (see eligibleForTestSuite).-createTestHs :: InitFlags -> IO ()-createTestHs flags =-  case testDirs flags of-    Just (testPath:_) -> writeTestHs flags (testPath </> testFile)-    _ -> writeMainHs flags testFile---- | Write a test file.-writeTestHs :: InitFlags -> FilePath -> IO ()-writeTestHs flags testPath = do-  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)-  let testFullPath = dir </> testPath-  exists <- doesFileExist testFullPath-  unless exists $ do-      message flags $ "Generating " ++ testPath ++ "..."-      writeFileSafe flags testFullPath testHs---- | Default MyLibTest.hs file.-testHs :: String-testHs = unlines-  [ "module Main (main) where"-  , ""-  , "main :: IO ()"-  , "main = putStrLn \"Test suite not yet implemented.\""-  ]----- | Move an existing file, if there is one, and the overwrite flag is---   not set.-moveExistingFile :: InitFlags -> FilePath -> IO ()-moveExistingFile flags fileName =-  unless (overwrite flags == Flag True) $ do-    e <- doesFileExist fileName-    when e $ do-      newName <- findNewName fileName-      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName-      copyFile fileName newName----- | Given a file path find a new name for the file that does not---   already exist.-findNewName :: FilePath -> IO FilePath-findNewName oldName = findNewName' 0-  where-    findNewName' :: Integer -> IO FilePath-    findNewName' n = do-      let newName = oldName <.> ("save" ++ show n)-      e <- doesFileExist newName-      if e then findNewName' (n+1) else return newName----- | Generate a .cabal file from an InitFlags structure.-generateCabalFile :: String -> InitFlags -> String-generateCabalFile fileName c =-    showFields' annCommentLines postProcessFieldLines 4 $ catMaybes-  [ fieldP "cabal-version" (Flag . SpecVersion $ specVer)-      []-      False--  , field "name" (packageName c)-      ["Initial package description '" ++ fileName ++ "' generated by",-       "'cabal init'. For further documentation, see:",-       "  http://haskell.org/cabal/users-guide/",-       "",-       "The name of the package."]-      True--  , field  "version"       (version       c)-           ["The package version.",-            "See the Haskell package versioning policy (PVP) for standards",-            "guiding when and how versions should be incremented.",-            "https://pvp.haskell.org",-            "PVP summary:      +-+------- breaking API changes",-            "                  | | +----- non-breaking API additions",-            "                  | | | +--- code changes with no API change"]-           True--  , fieldS "synopsis"      (synopsis      c)-           ["A short (one-line) description of the package."]-           True--  , fieldS "description"   NoFlag-           ["A longer description of the package."]-           True--  , fieldS "homepage"      (homepage     c)-           ["URL for the project homepage or repository."]-           False--  , fieldS "bug-reports"   NoFlag-           ["A URL where users can report bugs."]-           True--  , fieldS  "license"      licenseStr-                ["The license under which the package is released."]-                True--  , case license c of-      NoFlag         -> Nothing-      Flag SPDX.NONE -> Nothing-      _ -> fieldS "license-file" (Flag "LICENSE")-                  ["The file containing the license text."]-                  True--  , fieldS "author"        (author       c)-           ["The package author(s)."]-           True--  , fieldS "maintainer"    (email        c)-           ["An email address to which users can send suggestions, bug reports, and patches."]-           True--  , fieldS "copyright"     NoFlag-           ["A copyright notice."]-           True--  , fieldS "category"      (either id prettyShow `fmap` category c)-           []-           True--  , fieldS "build-type"    (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")-           []-           False--  , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c))-           ["Extra files to be distributed with the package, such as examples or a README."]-           True-  ]-  ++-  (case packageType c of-     Flag Executable -> [executableStanza]-     Flag Library    -> [libraryStanza]-     Flag LibraryAndExecutable -> [libraryStanza, executableStanza]-     _               -> [])-  ++-  if eligibleForTestSuite c then [testSuiteStanza] else []-- where-   specVer :: CabalSpecVersion-   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)--   licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c-              | otherwise               = prettyShow                   <$> license c--   generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation]-   generateBuildInfo buildType c' = catMaybes-     [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods)-       [ case buildType of-                 LibBuild    -> "Modules included in this library but not exported."-                 ExecBuild -> "Modules included in this executable, other than Main."]-       True--     , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c))-       ["LANGUAGE extensions used by modules in this package."]-       True--     , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies)-       ["Other library packages from which modules are imported."]-       True--     , fieldPAla "hs-source-dirs" formatHsSourceDirs-       (maybeToFlag (case buildType of-                                              LibBuild -> sourceDirs c-                                              ExecBuild -> applicationDirs c))-       ["Directories containing source files."]-       True--     , fieldS "build-tools" (listFieldS $ buildTools c)-       ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]-       False--     , field "default-language" (language c)-       ["Base language which the package is written in."]-       True-     ]-     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).-     where-       buildDependencies :: Maybe [Dependency]-       buildDependencies = (++ myLibDep) <$> dependencies c'--       myLibDep :: [Dependency]-       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild-                      then case packageName c' of-                             Flag pkgName ->-                               [mkDependency pkgName anyVersion mainLibSet]-                             _ -> []-                  else []--       -- Only include 'MyLib' in 'other-modules' of the executable.-       otherModsFromFlag = otherModules c'-       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]-                   then Nothing-                   else otherModsFromFlag--   listFieldS :: Maybe [String] -> Flag String-   listFieldS Nothing = NoFlag-   listFieldS (Just []) = NoFlag-   listFieldS (Just xs) = Flag . intercalate ", " $ xs--   -- | Construct a 'PrettyField' from a field that can be automatically-   --   converted to a 'Doc' via 'display'.-   field :: Pretty t-         => FieldName-         -> Flag t-         -> [String]-         -> Bool-         -> Maybe (PrettyField FieldAnnotation)-   field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag)--   -- | Construct a 'PrettyField' from a 'String' field.-   fieldS :: FieldName   -- ^ Name of the field-          -> Flag String -- ^ Field contents-          -> [String]    -- ^ Comment to explain the field-          -> Bool        -- ^ Should the field be included (commented out) even if blank?-          -> Maybe (PrettyField FieldAnnotation)-   fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag)--   -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied.-   fieldP :: Pretty a-          => FieldName-          -> Flag a-          -> [String]-          -> Bool-          -> Maybe (PrettyField FieldAnnotation)-   fieldP fieldName fieldContentsFlag fieldComments includeField =-     fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField--   -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper.-   fieldPAla-     :: (Pretty b, Newtype a b)-     => FieldName-     -> (a -> b)-     -> Flag a-     -> [String]-     -> Bool-     -> Maybe (PrettyField FieldAnnotation)-   fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField =-     fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField--   -- | Construct a 'PrettyField' from a 'Doc' Flag.-   fieldD :: FieldName   -- ^ Name of the field-          -> Flag Doc    -- ^ Field contents-          -> [String]    -- ^ Comment to explain the field-          -> Bool        -- ^ Should the field be included (commented out) even if blank?-          -> Maybe (PrettyField FieldAnnotation)-   fieldD fieldName fieldContentsFlag fieldComments includeField =-     case fieldContentsFlag of-       NoFlag ->-         -- If there is no content, optionally produce a commented out field.-         fieldSEmptyContents fieldName fieldComments includeField--       Flag fieldContents ->-         if isEmpty fieldContents-         then-           -- If the doc is empty, optionally produce a commented out field.-           fieldSEmptyContents fieldName fieldComments includeField-         else-           -- If the doc is not empty, produce a field.-           Just $ case (noComments c, minimal c) of-             -- If the "--no-comments" flag is set, strip comments.-             (Flag True, _) ->-               fieldSWithContents fieldName fieldContents []-             -- If the "--minimal" flag is set, strip comments.-             (_, Flag True) ->-               fieldSWithContents fieldName fieldContents []-             -- Otherwise, include comments.-             (_, _) ->-               fieldSWithContents fieldName fieldContents fieldComments--   -- | Optionally produce a field with no content (depending on flags).-   fieldSEmptyContents :: FieldName-                       -> [String]-                       -> Bool-                       -> Maybe (PrettyField FieldAnnotation)-   fieldSEmptyContents fieldName fieldComments includeField-     | not includeField || (minimal c == Flag True) =-         Nothing-     | otherwise =-         Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty)--   -- | Produce a field with content.-   fieldSWithContents :: FieldName-                      -> Doc-                      -> [String]-                      -> PrettyField FieldAnnotation-   fieldSWithContents fieldName fieldContents fieldComments =-     PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents--   executableStanza :: PrettyField FieldAnnotation-   executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes-     [ fieldS "main-is" (mainIs c)-       [".hs or .lhs file containing the Main module."]-       True-     ]-     ++-     generateBuildInfo ExecBuild c-     where-       exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c)--   libraryStanza :: PrettyField FieldAnnotation-   libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes-     [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c))-       ["Modules exported by the library."]-       True-     ]-     ++-     generateBuildInfo LibBuild c---   testSuiteStanza :: PrettyField FieldAnnotation-   testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes-     [ field "default-language" (language c)-       ["Base language which the package is written in."]-       True--     , fieldS "type" (Flag "exitcode-stdio-1.0")-       ["The interface type and version of the test suite."]-       True--     , fieldPAla "hs-source-dirs" formatHsSourceDirs-       (maybeToFlag (testDirs c))-       ["Directories containing source files."]-       True--     , fieldS "main-is" (Flag testFile)-       ["The entrypoint to the test suite."]-       True--     , fieldPAla  "build-depends" formatDependencyList (maybeToFlag (dependencies c))-       ["Test dependencies."]-       True-     ]-     where-       testSuiteName =-         text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c)---- | Annotations for cabal file PrettyField.-data FieldAnnotation = FieldAnnotation-  { annCommentedOut :: Bool-    -- ^ True iif the field and its contents should be commented out.-  , annCommentLines :: [String]-    -- ^ Comment lines to place before the field or section.-  }---- | A field annotation instructing the pretty printer to comment out the field---   and any contents, with no comments.-commentedOutWithComments :: [String] -> FieldAnnotation-commentedOutWithComments = FieldAnnotation True . map ("-- " ++)---- | A field annotation with the specified comment lines.-withComments :: [String] -> FieldAnnotation-withComments = FieldAnnotation False---- | A field annotation with no comments.-annNoComments :: FieldAnnotation-annNoComments = FieldAnnotation False []--postProcessFieldLines :: FieldAnnotation -> [String] -> [String]-postProcessFieldLines ann-  | annCommentedOut ann = map ("-- " ++)-  | otherwise = id
− Distribution/Client/Init/Heuristics.hs 
@@ -1,392 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Heuristics--- Copyright   :  (c) Benedikt Huber 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Heuristics for creating initial cabal files.----------------------------------------------------------------------------------module Distribution.Client.Init.Heuristics (-    guessPackageName,-    scanForModules,     SourceFileEntry(..),-    neededBuildPrograms,-    guessMainFileCandidates,-    guessAuthorNameMail,-    knownCategories,-) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Distribution.Utils.Generic (safeHead, safeTail, safeLast)--import Distribution.Simple.Setup (Flag(..), flagToMaybe)-import Distribution.ModuleName-    ( ModuleName, toFilePath )-import qualified Distribution.Package as P-import qualified Distribution.PackageDescription as PD-    ( category, packageDescription )-import Distribution.Client.Utils-         ( tryCanonicalizePath )-import Language.Haskell.Extension ( Extension )--import Distribution.Solver.Types.PackageIndex-    ( allPackagesByName )-import Distribution.Solver.Types.SourcePackage-    ( srcpkgDescription )--import Distribution.Client.Types ( SourcePackageDb(..) )-import Data.Char   ( isLower )-import Data.List   ( isInfixOf )-import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getCurrentDirectory, getDirectoryContents,-                          doesDirectoryExist, doesFileExist, getHomeDirectory, )-import Distribution.Compat.Environment ( getEnvironment )-import System.FilePath ( takeExtension, takeBaseName, dropExtension,-                         (</>), (<.>), splitDirectories, makeRelative )--import Distribution.Client.Init.Types     ( InitFlags(..) )-import Distribution.Client.Compat.Process ( readProcessWithExitCode )--import qualified Distribution.Utils.ShortText as ShortText---- | Return a list of candidate main files for this executable: top-level--- modules including the word 'Main' in the file name. The list is sorted in--- order of preference, shorter file names are preferred. 'Right's are existing--- 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.mkPackageName . repair . fromMaybe "" . safeLast . 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 isDigit c = invalid c-                          | otherwise     = valid c-    repairRest = repair' id ('-' :)---- |Data type of source files found in the working directory-data SourceFileEntry = SourceFileEntry-    { relativeSourcePath :: FilePath-    , moduleName         :: ModuleName-    , fileExtension      :: String-    , imports            :: [ModuleName]-    , extensions         :: [Extension]-    } deriving Show--sfToFileName :: FilePath -> SourceFileEntry -> FilePath-sfToFileName projectRoot (SourceFileEntry relPath m ext _ _)-  = projectRoot </> relPath </> toFilePath m <.> ext---- |Search for source files in the given directory--- and return pairs of guessed Haskell source path and--- module names.-scanForModules :: FilePath -> IO [SourceFileEntry]-scanForModules rootDir = scanForModulesIn rootDir rootDir--scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry]-scanForModulesIn projectRoot srcRoot = scan srcRoot []-  where-    scan dir hierarchy = do-        entries <- getDirectoryContents (projectRoot </> dir)-        (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries)-        let modules = catMaybes [ guessModuleName hierarchy file-                                | file <- files-                                , maybe False isUpper (safeHead file) ]-        modules' <- traverse (findImportsAndExts projectRoot) modules-        recMods <- traverse (scanRecursive dir hierarchy) dirs-        return $ concat (modules' : recMods)-    tagIsDir parent entry = do-        isDir <- doesDirectoryExist (parent </> entry)-        return $ (if isDir then Right else Left) entry-    guessModuleName hierarchy entry-        | takeBaseName entry == "Setup" = Nothing-        | ext `elem` sourceExtensions   =-            SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure []-        | otherwise = Nothing-      where-        relRoot       = makeRelative projectRoot srcRoot-        unqualModName = dropExtension entry-        modName       = simpleParsec-                      $ intercalate "." . reverse $ (unqualModName : hierarchy)-        ext           = case takeExtension entry of '.':e -> e; e -> e-    scanRecursive parent hierarchy entry-      | maybe False isUpper (safeHead entry) = scan (parent </> entry) (entry : hierarchy)-      | maybe False isLower (safeHead entry) && not (ignoreDir entry) =-          scanForModulesIn projectRoot $ foldl (</>) srcRoot (reverse (entry : hierarchy))-      | otherwise = return []-    ignoreDir ('.':_)  = True-    ignoreDir dir      = dir `elem` ["dist", "_darcs"]--findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry-findImportsAndExts projectRoot sf = do-  s <- readFile (sfToFileName projectRoot sf)--  let modules = mapMaybe-                ( getModName-                . drop 1-                . filter (not . null)-                . dropWhile (/= "import")-                . words-                )-              . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering-              . lines-              $ s--      -- TODO: We should probably make a better attempt at parsing-      -- comments above.  Unfortunately we can't use a full-fledged-      -- Haskell parser since cabal's dependencies must be kept at a-      -- minimum.--      -- A poor man's LANGUAGE pragma parser.-      exts = mapMaybe simpleParsec-           . concatMap getPragmas-           . filter isLANGUAGEPragma-           . map fst-           . drop 1-           . takeWhile (not . null . snd)-           . iterate (takeBraces . snd)-           $ ("",s)--      takeBraces = break (== '}') . dropWhile (/= '{')--      isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`)--      getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13--      splitCommas "" = []-      splitCommas xs = x : splitCommas (drop 1 y)-        where (x,y) = break (==',') xs--  return sf { imports    = modules-            , extensions = exts-            }-- where getModName :: [String] -> Maybe ModuleName-       getModName []               = Nothing-       getModName ("qualified":ws) = getModName ws-       getModName (ms:_)           = simpleParsec ms------ Unfortunately we cannot use the version exported by Distribution.Simple.Program-knownSuffixHandlers :: [(String,String)]-knownSuffixHandlers =-  [ ("gc",     "greencard")-  , ("chs",    "chs")-  , ("hsc",    "hsc2hs")-  , ("x",      "alex")-  , ("y",      "happy")-  , ("ly",     "happy")-  , ("cpphs",  "cpp")-  ]--sourceExtensions :: [String]-sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers--neededBuildPrograms :: [SourceFileEntry] -> [String]-neededBuildPrograms entries =-    [ handler-    | ext <- nubSet (map fileExtension entries)-    , handler <- maybeToList (lookup ext knownSuffixHandlers)-    ]---- | Guess author and email using darcs and git configuration options. Use--- the following in decreasing order of preference:------ 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*)--- 2. Local repo configs--- 3. Global vcs configs--- 4. The generic $EMAIL------ Name and email are processed separately, so the guess might end up being--- a name from DARCS_EMAIL and an email from git config.------ Darcs has preference, for tradition's sake.-guessAuthorNameMail :: IO (Flag String, Flag String)-guessAuthorNameMail = fmap authorGuessPure authorGuessIO---- Ordered in increasing preference, since Flag-as-monoid is identical to--- Last.-authorGuessPure :: AuthorGuessIO -> AuthorGuess-authorGuessPure (AuthorGuessIO { authorGuessEnv = env-                               , authorGuessLocalDarcs = darcsLocalF-                               , authorGuessGlobalDarcs = darcsGlobalF-                               , authorGuessLocalGit = gitLocal-                               , authorGuessGlobalGit = gitGlobal })-    = mconcat-        [ emailEnv env-        , gitGlobal-        , darcsCfg darcsGlobalF-        , gitLocal-        , darcsCfg darcsLocalF-        , gitEnv env-        , darcsEnv env-        ]--authorGuessIO :: IO AuthorGuessIO-authorGuessIO = AuthorGuessIO-    <$> getEnvironment-    <*> (maybeReadFile $ "_darcs" </> "prefs" </> "author")-    <*> (maybeReadFile =<< liftM (</> (".darcs" </> "author")) getHomeDirectory)-    <*> gitCfg Local-    <*> gitCfg Global---- Types and functions used for guessing the author are now defined:--type AuthorGuess   = (Flag String, Flag String)-type Enviro        = [(String, String)]-data GitLoc        = Local | Global-data AuthorGuessIO = AuthorGuessIO {-    authorGuessEnv         :: Enviro,         -- ^ Environment lookup table-    authorGuessLocalDarcs  :: (Maybe String), -- ^ Contents of local darcs author info-    authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info-    authorGuessLocalGit    :: AuthorGuess,   -- ^ Git config --local-    authorGuessGlobalGit   :: AuthorGuess    -- ^ Git config --global-  }--darcsEnv :: Enviro -> AuthorGuess-darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"--gitEnv :: Enviro -> AuthorGuess-gitEnv env = (name, mail)-  where-    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, mail)-  where-    mail = maybeFlag "EMAIL" env--gitCfg :: GitLoc -> IO AuthorGuess-gitCfg which = do-  name <- gitVar which "user.name"-  mail <- gitVar which "user.email"-  return (name, mail)--gitVar :: GitLoc -> String -> IO (Flag String)-gitVar which = fmap happyOutput . gitConfigQuery which--happyOutput :: (ExitCode, a, t) -> Flag a-happyOutput v = case v of-  (ExitSuccess, s, _) -> Flag s-  _                   -> mempty--gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String)-gitConfigQuery which key =-    fmap trim' $ readProcessWithExitCode "git" ["config", w, key] ""-  where-    w = case which of-        Local  -> "--local"-        Global -> "--global"-    trim' (a, b, c) = (a, trim b, c)--maybeFlag :: String -> Enviro -> Flag String-maybeFlag k = maybe mempty Flag . lookup k---- | Read the first non-comment, non-trivial line of a file, if it exists-maybeReadFile :: String -> IO (Maybe String)-maybeReadFile f = do-    exists <- doesFileExist f-    if exists-        then fmap getFirstLine $ readFile f-        else return Nothing-  where-    getFirstLine content =-      let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content-      in case nontrivialLines of-           [] -> Nothing-           (l:_) -> Just l---- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached-knownCategories :: SourcePackageDb -> [String]-knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet-    [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex)-          , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg-          , cat <- splitString ',' $ ShortText.fromShortText catList-    ]---- Parse name and email, from darcs pref files or environment variable-nameAndMail :: String -> (Flag String, Flag String)-nameAndMail str-  | all isSpace nameOrEmail = mempty-  | null erest = (mempty, Flag $ trim nameOrEmail)-  | otherwise  = (Flag $ trim nameOrEmail, Flag mail)-  where-    (nameOrEmail,erest) = break (== '<') str-    (mail,_)            = break (== '>') (safeTail erest)--trim :: String -> String-trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse-  where-    removeLeadingSpace  = dropWhile isSpace---- 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-      s' = dropWhile (\c -> c == sep || isSpace c) s-      (tok,rest) = break (==sep) s'--nubSet :: (Ord a) => [a] -> [a]-nubSet = Set.toList . Set.fromList--{--test db testProjectRoot = do-  putStrLn "Guessed package name"-  (guessPackageName >=> print) testProjectRoot-  putStrLn "Guessed name and email"-  guessAuthorNameMail >>= print--  mods <- scanForModules testProjectRoot--  putStrLn "Guessed modules"-  mapM_ print mods-  putStrLn "Needed build programs"-  print (neededBuildPrograms mods)--  putStrLn "List of known categories"-  print $ knownCategories db--}
− Distribution/Client/Init/Licenses.hs 
@@ -1,3077 +0,0 @@-{-|-Module        :  Distribution.Client.Init.Licenses--Description   :  Factory functions for producing known license types.--License       :  BSD-like-Maintainer    :  cabal-devel@haskell.org-Stability     :  provisional-Portability   :  portable--}-module Distribution.Client.Init.Licenses-  ( License-  , bsd2-  , bsd3-  , gplv2-  , gplv3-  , lgpl21-  , lgpl3-  , agplv3-  , apache20-  , mit-  , mpl20-  , isc-  ) where--import Prelude (String, unlines, (++))--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-    , ""-    , "All rights reserved."-    , ""-    , "Redistribution and use in source and binary forms, with or without"-    , "modification, are permitted provided that the following conditions are met:"-    , ""-    , "    * Redistributions of source code must retain the above copyright"-    , "      notice, this list of conditions and the following disclaimer."-    , ""-    , "    * 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."-    , ""-    , "    * Neither the name of " ++ authors ++ " nor the names of other"-    , "      contributors may be used to endorse or promote products derived"-    , "      from this software without specific prior written permission."-    , ""-    , "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."-    ]--gplv2 :: License-gplv2 = unlines-    [ "             GNU GENERAL PUBLIC LICENSE"-    , "                Version 2, June 1991"-    , ""-    , " Copyright (C) 1989, 1991 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."-    , ""-    , "                     Preamble"-    , ""-    , "  The licenses for most software are designed to take away your"-    , "freedom to share and change it.  By contrast, the GNU General Public"-    , "License is intended to guarantee your freedom to share and change free"-    , "software--to make sure the software is free for all its users.  This"-    , "General Public License applies to most of the Free Software"-    , "Foundation's software and to any other program whose authors commit to"-    , "using it.  (Some other Free Software Foundation software is covered by"-    , "the GNU Lesser General Public License instead.)  You can apply it to"-    , "your programs, too."-    , ""-    , "  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."-    , ""-    , "  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 software, or if you modify it."-    , ""-    , "  For example, if you distribute copies of such a program, whether"-    , "gratis or for a fee, you must give the recipients all the rights that"-    , "you have.  You must make sure that they, too, receive or can get the"-    , "source code.  And you must show them these terms so they know their"-    , "rights."-    , ""-    , "  We protect your rights with two steps: (1) copyright the software, and"-    , "(2) offer you this license which gives you legal permission to copy,"-    , "distribute and/or modify the software."-    , ""-    , "  Also, for each author's protection and ours, we want to make certain"-    , "that everyone understands that there is no warranty for this free"-    , "software.  If the software is modified by someone else and passed on, we"-    , "want its recipients to know that what they have is not the original, so"-    , "that any problems introduced by others will not reflect on the original"-    , "authors' reputations."-    , ""-    , "  Finally, any free program is threatened constantly by software"-    , "patents.  We wish to avoid the danger that redistributors of a free"-    , "program will individually obtain patent licenses, in effect making the"-    , "program proprietary.  To prevent this, we have made it clear that any"-    , "patent must be licensed for everyone's free use or not licensed at all."-    , ""-    , "  The precise terms and conditions for copying, distribution and"-    , "modification follow."-    , ""-    , "             GNU GENERAL PUBLIC LICENSE"-    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"-    , ""-    , "  0. This License applies to any program or other work which contains"-    , "a notice placed by the copyright holder saying it may be distributed"-    , "under the terms of this General Public License.  The \"Program\", below,"-    , "refers to any such program or work, and a \"work based on the Program\""-    , "means either the Program or any derivative work under copyright law:"-    , "that is to say, a work containing the Program or a portion of it,"-    , "either verbatim or with modifications and/or translated into another"-    , "language.  (Hereinafter, translation is included without limitation in"-    , "the term \"modification\".)  Each licensee is addressed as \"you\"."-    , ""-    , "Activities other than copying, distribution and modification are not"-    , "covered by this License; they are outside its scope.  The act of"-    , "running the Program is not restricted, and the output from the Program"-    , "is covered only if its contents constitute a work based on the"-    , "Program (independent of having been made by running the Program)."-    , "Whether that is true depends on what the Program does."-    , ""-    , "  1. You may copy and distribute verbatim copies of the Program's"-    , "source code as you receive it, in any medium, provided that you"-    , "conspicuously and appropriately publish on each copy an appropriate"-    , "copyright notice and disclaimer of warranty; keep intact all the"-    , "notices that refer to this License and to the absence of any warranty;"-    , "and give any other recipients of the Program a copy of this License"-    , "along with the Program."-    , ""-    , "You may charge a fee for the physical act of transferring a copy, and"-    , "you may at your option offer warranty protection in exchange for a fee."-    , ""-    , "  2. You may modify your copy or copies of the Program or any portion"-    , "of it, thus forming a work based on the Program, and copy and"-    , "distribute such modifications or work under the terms of Section 1"-    , "above, provided that you also meet all of these conditions:"-    , ""-    , "    a) You must cause the modified files to carry prominent notices"-    , "    stating that you changed the files and the date of any change."-    , ""-    , "    b) You must cause any work that you distribute or publish, that in"-    , "    whole or in part contains or is derived from the Program or any"-    , "    part thereof, to be licensed as a whole at no charge to all third"-    , "    parties under the terms of this License."-    , ""-    , "    c) If the modified program normally reads commands interactively"-    , "    when run, you must cause it, when started running for such"-    , "    interactive use in the most ordinary way, to print or display an"-    , "    announcement including an appropriate copyright notice and a"-    , "    notice that there is no warranty (or else, saying that you provide"-    , "    a warranty) and that users may redistribute the program under"-    , "    these conditions, and telling the user how to view a copy of this"-    , "    License.  (Exception: if the Program itself is interactive but"-    , "    does not normally print such an announcement, your work based on"-    , "    the Program is not required to print an announcement.)"-    , ""-    , "These requirements apply to the modified work as a whole.  If"-    , "identifiable sections of that work are not derived from the Program,"-    , "and can be reasonably considered independent and separate works in"-    , "themselves, then this License, and its terms, do not apply to those"-    , "sections when you distribute them as separate works.  But when you"-    , "distribute the same sections as part of a whole which is a work based"-    , "on the Program, the distribution of the whole must be on the terms of"-    , "this License, whose permissions for other licensees extend to the"-    , "entire whole, and thus to each and every part regardless of who wrote it."-    , ""-    , "Thus, it is not the intent of this section to claim rights or contest"-    , "your rights to work written entirely by you; rather, the intent is to"-    , "exercise the right to control the distribution of derivative or"-    , "collective works based on the Program."-    , ""-    , "In addition, mere aggregation of another work not based on the Program"-    , "with the Program (or with a work based on the Program) on a volume of"-    , "a storage or distribution medium does not bring the other work under"-    , "the scope of this License."-    , ""-    , "  3. You may copy and distribute the Program (or a work based on it,"-    , "under Section 2) in object code or executable form under the terms of"-    , "Sections 1 and 2 above provided that you also do one of the following:"-    , ""-    , "    a) Accompany it with the complete corresponding machine-readable"-    , "    source code, which must be distributed under the terms of Sections"-    , "    1 and 2 above on a medium customarily used for software interchange; or,"-    , ""-    , "    b) Accompany it with a written offer, valid for at least three"-    , "    years, to give any third party, for a charge no more than your"-    , "    cost of physically performing source distribution, a complete"-    , "    machine-readable copy of the corresponding source code, to be"-    , "    distributed under the terms of Sections 1 and 2 above on a medium"-    , "    customarily used for software interchange; or,"-    , ""-    , "    c) Accompany it with the information you received as to the offer"-    , "    to distribute corresponding source code.  (This alternative is"-    , "    allowed only for noncommercial distribution and only if you"-    , "    received the program in object code or executable form with such"-    , "    an offer, in accord with Subsection b above.)"-    , ""-    , "The source code for a work means the preferred form of the work for"-    , "making modifications to it.  For an executable work, complete source"-    , "code means all the source code for all modules it contains, plus any"-    , "associated interface definition files, plus the scripts used to"-    , "control compilation and installation of the executable.  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 components (compiler, kernel, and so on) of the"-    , "operating system on which the executable runs, unless that component"-    , "itself accompanies the executable."-    , ""-    , "If distribution of executable or object code is made by offering"-    , "access to copy from a designated place, then offering equivalent"-    , "access to copy the source code from the same place counts as"-    , "distribution of the source code, even though third parties are not"-    , "compelled to copy the source along with the object code."-    , ""-    , "  4. You may not copy, modify, sublicense, or distribute the Program"-    , "except as expressly provided under this License.  Any attempt"-    , "otherwise to copy, modify, sublicense or distribute the Program is"-    , "void, and will automatically terminate your rights under this License."-    , "However, parties who have received copies, or rights, from you under"-    , "this License will not have their licenses terminated so long as such"-    , "parties remain in full compliance."-    , ""-    , "  5. You are not required to accept this License, since you have not"-    , "signed it.  However, nothing else grants you permission to modify or"-    , "distribute the Program or its derivative works.  These actions are"-    , "prohibited by law if you do not accept this License.  Therefore, by"-    , "modifying or distributing the Program (or any work based on the"-    , "Program), you indicate your acceptance of this License to do so, and"-    , "all its terms and conditions for copying, distributing or modifying"-    , "the Program or works based on it."-    , ""-    , "  6. Each time you redistribute the Program (or any work based on the"-    , "Program), the recipient automatically receives a license from the"-    , "original licensor to copy, distribute or modify the Program 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"-    , "this License."-    , ""-    , "  7. If, as a consequence of a court judgment or allegation of patent"-    , "infringement or for any other reason (not limited to patent issues),"-    , "conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot"-    , "distribute so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you"-    , "may not distribute the Program at all.  For example, if a patent"-    , "license would not permit royalty-free redistribution of the Program by"-    , "all those who receive copies directly or indirectly through you, then"-    , "the only way you could satisfy both it and this License would be to"-    , "refrain entirely from distribution of the Program."-    , ""-    , "If any portion of this section is held invalid or unenforceable under"-    , "any particular circumstance, the balance of the section is intended to"-    , "apply and the section as a whole is intended to apply in other"-    , "circumstances."-    , ""-    , "It is not the purpose of this section to induce you to infringe any"-    , "patents or other property right claims or to contest validity of any"-    , "such claims; this section has the sole purpose of protecting the"-    , "integrity of the free software distribution system, which is"-    , "implemented by public license practices.  Many people have made"-    , "generous contributions to the wide range of software distributed"-    , "through that system in reliance on consistent application of that"-    , "system; it is up to the author/donor to decide if he or she is willing"-    , "to distribute software through any other system and a licensee cannot"-    , "impose that choice."-    , ""-    , "This section is intended to make thoroughly clear what is believed to"-    , "be a consequence of the rest of this License."-    , ""-    , "  8. If the distribution and/or use of the Program is restricted in"-    , "certain countries either by patents or by copyrighted interfaces, the"-    , "original copyright holder who places the Program under this License"-    , "may add an explicit geographical distribution limitation excluding"-    , "those countries, so that distribution is permitted only in or among"-    , "countries not thus excluded.  In such case, this License incorporates"-    , "the limitation as if written in the body of this License."-    , ""-    , "  9. The Free Software Foundation may publish revised and/or new versions"-    , "of the 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."-    , ""-    , "Each version is given a distinguishing version number.  If the Program"-    , "specifies a version number of this License which applies to it and \"any"-    , "later version\", you have the option of following the terms and conditions"-    , "either of that version or of any later version published by the Free"-    , "Software Foundation.  If the Program does not specify a version number of"-    , "this License, you may choose any version ever published by the Free Software"-    , "Foundation."-    , ""-    , "  10. If you wish to incorporate parts of the Program into other free"-    , "programs whose distribution conditions are different, write to the author"-    , "to ask for permission.  For software which is copyrighted by the Free"-    , "Software Foundation, write to the Free Software Foundation; we sometimes"-    , "make exceptions for this.  Our decision will be guided by the two goals"-    , "of preserving the free status of all derivatives of our free software and"-    , "of promoting the sharing and reuse of software generally."-    , ""-    , "                     NO WARRANTY"-    , ""-    , "  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY"-    , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN"-    , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES"-    , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED"-    , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF"-    , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS"-    , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE"-    , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,"-    , "REPAIR OR CORRECTION."-    , ""-    , "  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"-    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR"-    , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,"-    , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING"-    , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED"-    , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY"-    , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER"-    , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE"-    , "POSSIBILITY OF SUCH DAMAGES."-    , ""-    , "              END OF TERMS AND CONDITIONS"-    , ""-    , "     How to Apply These Terms to Your New Programs"-    , ""-    , "  If you develop a new program, and you want it to be of the greatest"-    , "possible use to the public, the best way to achieve this is to make it"-    , "free software which everyone can redistribute and change under these terms."-    , ""-    , "  To do so, attach the following notices to the program.  It is safest"-    , "to attach them to the start of each source file to most effectively"-    , "convey the exclusion of warranty; and each file should have at least"-    , "the \"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the program's name and a brief idea of what it does.>"-    , "    Copyright (C) <year>  <name of author>"-    , ""-    , "    This program is free software; you can redistribute it and/or modify"-    , "    it under the terms of the GNU General Public License as published by"-    , "    the Free Software Foundation; either version 2 of the License, or"-    , "    (at your option) any later version."-    , ""-    , "    This program 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 General Public License for more details."-    , ""-    , "    You should have received a copy of the GNU General Public License along"-    , "    with this program; 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."-    , ""-    , "If the program is interactive, make it output a short notice like this"-    , "when it starts in an interactive mode:"-    , ""-    , "    Gnomovision version 69, Copyright (C) year name of author"-    , "    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'."-    , "    This is free software, and you are welcome to redistribute it"-    , "    under certain conditions; type `show c' for details."-    , ""-    , "The hypothetical commands `show w' and `show c' should show the appropriate"-    , "parts of the General Public License.  Of course, the commands you use may"-    , "be called something other than `show w' and `show c'; they could even be"-    , "mouse-clicks or menu items--whatever suits your program."-    , ""-    , "You should also get your employer (if you work as a programmer) or your"-    , "school, if any, to sign a \"copyright disclaimer\" for the program, if"-    , "necessary.  Here is a sample; alter the names:"-    , ""-    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the program"-    , "  `Gnomovision' (which makes passes at compilers) written by James Hacker."-    , ""-    , "  <signature of Ty Coon>, 1 April 1989"-    , "  Ty Coon, President of Vice"-    , ""-    , "This General Public License does not permit incorporating your program into"-    , "proprietary programs.  If your program is a subroutine library, you may"-    , "consider it more useful to permit linking proprietary applications with the"-    , "library.  If this is what you want to do, use the GNU Lesser General"-    , "Public License instead of this License."-    ]--gplv3 :: License-gplv3 = unlines-    [ "              GNU GENERAL PUBLIC LICENSE"-    , "                Version 3, 29 June 2007"-    , ""-    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , "                     Preamble"-    , ""-    , "  The GNU General Public License is a free, copyleft license for"-    , "software and other kinds of works."-    , ""-    , "  The licenses for most software and other practical works are designed"-    , "to take away your freedom to share and change the works.  By contrast,"-    , "the GNU General Public License is intended to guarantee your freedom to"-    , "share and change all versions of a program--to make sure it remains free"-    , "software for all its users.  We, the Free Software Foundation, use the"-    , "GNU General Public License for most of our software; it applies also to"-    , "any other work released this way by its authors.  You can apply it to"-    , "your programs, too."-    , ""-    , "  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"-    , "them 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."-    , ""-    , "  To protect your rights, we need to prevent others from denying you"-    , "these rights or asking you to surrender the rights.  Therefore, you have"-    , "certain responsibilities if you distribute copies of the software, or if"-    , "you modify it: responsibilities to respect the freedom of others."-    , ""-    , "  For example, if you distribute copies of such a program, whether"-    , "gratis or for a fee, you must pass on to the recipients the same"-    , "freedoms that you received.  You must make sure that they, too, receive"-    , "or can get the source code.  And you must show them these terms so they"-    , "know their rights."-    , ""-    , "  Developers that use the GNU GPL protect your rights with two steps:"-    , "(1) assert copyright on the software, and (2) offer you this License"-    , "giving you legal permission to copy, distribute and/or modify it."-    , ""-    , "  For the developers' and authors' protection, the GPL clearly explains"-    , "that there is no warranty for this free software.  For both users' and"-    , "authors' sake, the GPL requires that modified versions be marked as"-    , "changed, so that their problems will not be attributed erroneously to"-    , "authors of previous versions."-    , ""-    , "  Some devices are designed to deny users access to install or run"-    , "modified versions of the software inside them, although the manufacturer"-    , "can do so.  This is fundamentally incompatible with the aim of"-    , "protecting users' freedom to change the software.  The systematic"-    , "pattern of such abuse occurs in the area of products for individuals to"-    , "use, which is precisely where it is most unacceptable.  Therefore, we"-    , "have designed this version of the GPL to prohibit the practice for those"-    , "products.  If such problems arise substantially in other domains, we"-    , "stand ready to extend this provision to those domains in future versions"-    , "of the GPL, as needed to protect the freedom of users."-    , ""-    , "  Finally, every program is threatened constantly by software patents."-    , "States should not allow patents to restrict development and use of"-    , "software on general-purpose computers, but in those that do, we wish to"-    , "avoid the special danger that patents applied to a free program could"-    , "make it effectively proprietary.  To prevent this, the GPL assures that"-    , "patents cannot be used to render the program non-free."-    , ""-    , "  The precise terms and conditions for copying, distribution and"-    , "modification follow."-    , ""-    , "                TERMS AND CONDITIONS"-    , ""-    , "  0. Definitions."-    , ""-    , "  \"This License\" refers to version 3 of the GNU General Public License."-    , ""-    , "  \"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."-    , ""-    , "  To \"modify\" a work means to copy from or adapt all or part of the work"-    , "in a fashion requiring copyright permission, other than the making of an"-    , "exact copy.  The resulting work is called a \"modified version\" of the"-    , "earlier work or a work \"based on\" the earlier work."-    , ""-    , "  A \"covered work\" means either the unmodified Program or a work based"-    , "on the Program."-    , ""-    , "  To \"propagate\" a work means to do anything with it that, without"-    , "permission, would make you directly or secondarily liable for"-    , "infringement under applicable copyright law, except executing it on a"-    , "computer or modifying a private copy.  Propagation includes copying,"-    , "distribution (with or without modification), making available to the"-    , "public, and in some countries other activities as well."-    , ""-    , "  To \"convey\" a work means any kind of propagation that enables other"-    , "parties to make or receive copies.  Mere interaction with a user through"-    , "a computer network, with no transfer of a copy, is not conveying."-    , ""-    , "  An interactive user interface displays \"Appropriate Legal Notices\""-    , "to the extent that it includes a convenient and prominently visible"-    , "feature that (1) displays an appropriate copyright notice, and (2)"-    , "tells the user that there is no warranty for the work (except to the"-    , "extent that warranties are provided), that licensees may convey the"-    , "work under this License, and how to view a copy of this License.  If"-    , "the interface presents a list of user commands or options, such as a"-    , "menu, a prominent item in the list meets this criterion."-    , ""-    , "  1. Source Code."-    , ""-    , "  The \"source code\" for a work means the preferred form of the work"-    , "for making modifications to it.  \"Object code\" means any non-source"-    , "form of a work."-    , ""-    , "  A \"Standard Interface\" means an interface that either is an official"-    , "standard defined by a recognized standards body, or, in the case of"-    , "interfaces specified for a particular programming language, one that"-    , "is widely used among developers working in that language."-    , ""-    , "  The \"System Libraries\" of an executable work include anything, other"-    , "than the work as a whole, that (a) is included in the normal form of"-    , "packaging a Major Component, but which is not part of that Major"-    , "Component, and (b) serves only to enable use of the work with that"-    , "Major Component, or to implement a Standard Interface for which an"-    , "implementation is available to the public in source code form.  A"-    , "\"Major Component\", in this context, means a major essential component"-    , "(kernel, window system, and so on) of the specific operating system"-    , "(if any) on which the executable work runs, or a compiler used to"-    , "produce the work, or an object code interpreter used to run it."-    , ""-    , "  The \"Corresponding Source\" for a work in object code form means all"-    , "the source code needed to generate, install, and (for an executable"-    , "work) run the object code and to modify the work, including scripts to"-    , "control those activities.  However, it does not include the work's"-    , "System Libraries, or general-purpose tools or generally available free"-    , "programs which are used unmodified in performing those activities but"-    , "which are not part of the work.  For example, Corresponding Source"-    , "includes interface definition files associated with source files for"-    , "the work, and the source code for shared libraries and dynamically"-    , "linked subprograms that the work is specifically designed to require,"-    , "such as by intimate data communication or control flow between those"-    , "subprograms and other parts of the work."-    , ""-    , "  The Corresponding Source need not include anything that users"-    , "can regenerate automatically from other parts of the Corresponding"-    , "Source."-    , ""-    , "  The Corresponding Source for a work in source code form is that"-    , "same work."-    , ""-    , "  2. Basic Permissions."-    , ""-    , "  All rights granted under this License are granted for the term of"-    , "copyright on the Program, and are irrevocable provided the stated"-    , "conditions are met.  This License explicitly affirms your unlimited"-    , "permission to run the unmodified Program.  The output from running a"-    , "covered work is covered by this License only if the output, given its"-    , "content, constitutes a covered work.  This License acknowledges your"-    , "rights of fair use or other equivalent, as provided by copyright law."-    , ""-    , "  You may make, run and propagate covered works that you do not"-    , "convey, without conditions so long as your license otherwise remains"-    , "in force.  You may convey covered works to others for the sole purpose"-    , "of having them make modifications exclusively for you, or provide you"-    , "with facilities for running those works, provided that you comply with"-    , "the terms of this License in conveying all material for which you do"-    , "not control copyright.  Those thus making or running the covered works"-    , "for you must do so exclusively on your behalf, under your direction"-    , "and control, on terms that prohibit them from making any copies of"-    , "your copyrighted material outside their relationship with you."-    , ""-    , "  Conveying under any other circumstances is permitted solely under"-    , "the conditions stated below.  Sublicensing is not allowed; section 10"-    , "makes it unnecessary."-    , ""-    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."-    , ""-    , "  No covered work shall be deemed part of an effective technological"-    , "measure under any applicable law fulfilling obligations under article"-    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"-    , "similar laws prohibiting or restricting circumvention of such"-    , "measures."-    , ""-    , "  When you convey a covered work, you waive any legal power to forbid"-    , "circumvention of technological measures to the extent such circumvention"-    , "is effected by exercising rights under this License with respect to"-    , "the covered work, and you disclaim any intention to limit operation or"-    , "modification of the work as a means of enforcing, against the work's"-    , "users, your or third parties' legal rights to forbid circumvention of"-    , "technological measures."-    , ""-    , "  4. Conveying Verbatim Copies."-    , ""-    , "  You may convey verbatim copies of the Program's source code as you"-    , "receive it, in any medium, provided that you conspicuously and"-    , "appropriately publish on each copy an appropriate copyright notice;"-    , "keep intact all notices stating that this License and any"-    , "non-permissive terms added in accord with section 7 apply to the code;"-    , "keep intact all notices of the absence of any warranty; and give all"-    , "recipients a copy of this License along with the Program."-    , ""-    , "  You may charge any price or no price for each copy that you convey,"-    , "and you may offer support or warranty protection for a fee."-    , ""-    , "  5. Conveying Modified Source Versions."-    , ""-    , "  You may convey a work based on the Program, or the modifications to"-    , "produce it from the Program, in the form of source code under the"-    , "terms of section 4, provided that you also meet all of these conditions:"-    , ""-    , "    a) The work must carry prominent notices stating that you modified"-    , "    it, and giving a relevant date."-    , ""-    , "    b) The work must carry prominent notices stating that it is"-    , "    released under this License and any conditions added under section"-    , "    7.  This requirement modifies the requirement in section 4 to"-    , "    \"keep intact all notices\"."-    , ""-    , "    c) You must license the entire work, as a whole, under this"-    , "    License to anyone who comes into possession of a copy.  This"-    , "    License will therefore apply, along with any applicable section 7"-    , "    additional terms, to the whole of the work, and all its parts,"-    , "    regardless of how they are packaged.  This License gives no"-    , "    permission to license the work in any other way, but it does not"-    , "    invalidate such permission if you have separately received it."-    , ""-    , "    d) If the work has interactive user interfaces, each must display"-    , "    Appropriate Legal Notices; however, if the Program has interactive"-    , "    interfaces that do not display Appropriate Legal Notices, your"-    , "    work need not make them do so."-    , ""-    , "  A compilation of a covered work with other separate and independent"-    , "works, which are not by their nature extensions of the covered work,"-    , "and which are not combined with it such as to form a larger program,"-    , "in or on a volume of a storage or distribution medium, is called an"-    , "\"aggregate\" if the compilation and its resulting copyright are not"-    , "used to limit the access or legal rights of the compilation's users"-    , "beyond what the individual works permit.  Inclusion of a covered work"-    , "in an aggregate does not cause this License to apply to the other"-    , "parts of the aggregate."-    , ""-    , "  6. Conveying Non-Source Forms."-    , ""-    , "  You may convey a covered work in object code form under the terms"-    , "of sections 4 and 5, provided that you also convey the"-    , "machine-readable Corresponding Source under the terms of this License,"-    , "in one of these ways:"-    , ""-    , "    a) Convey the object code in, or embodied in, a physical product"-    , "    (including a physical distribution medium), accompanied by the"-    , "    Corresponding Source fixed on a durable physical medium"-    , "    customarily used for software interchange."-    , ""-    , "    b) Convey the object code in, or embodied in, a physical product"-    , "    (including a physical distribution medium), accompanied by a"-    , "    written offer, valid for at least three years and valid for as"-    , "    long as you offer spare parts or customer support for that product"-    , "    model, to give anyone who possesses the object code either (1) a"-    , "    copy of the Corresponding Source for all the software in the"-    , "    product that is covered by this License, on a durable physical"-    , "    medium customarily used for software interchange, for a price no"-    , "    more than your reasonable cost of physically performing this"-    , "    conveying of source, or (2) access to copy the"-    , "    Corresponding Source from a network server at no charge."-    , ""-    , "    c) Convey individual copies of the object code with a copy of the"-    , "    written offer to provide the Corresponding Source.  This"-    , "    alternative is allowed only occasionally and noncommercially, and"-    , "    only if you received the object code with such an offer, in accord"-    , "    with subsection 6b."-    , ""-    , "    d) Convey the object code by offering access from a designated"-    , "    place (gratis or for a charge), and offer equivalent access to the"-    , "    Corresponding Source in the same way through the same place at no"-    , "    further charge.  You need not require recipients to copy the"-    , "    Corresponding Source along with the object code.  If the place to"-    , "    copy the object code is a network server, the Corresponding Source"-    , "    may be on a different server (operated by you or a third party)"-    , "    that supports equivalent copying facilities, provided you maintain"-    , "    clear directions next to the object code saying where to find the"-    , "    Corresponding Source.  Regardless of what server hosts the"-    , "    Corresponding Source, you remain obligated to ensure that it is"-    , "    available for as long as needed to satisfy these requirements."-    , ""-    , "    e) Convey the object code using peer-to-peer transmission, provided"-    , "    you inform other peers where the object code and Corresponding"-    , "    Source of the work are being offered to the general public at no"-    , "    charge under subsection 6d."-    , ""-    , "  A separable portion of the object code, whose source code is excluded"-    , "from the Corresponding Source as a System Library, need not be"-    , "included in conveying the object code work."-    , ""-    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"-    , "tangible personal property which is normally used for personal, family,"-    , "or household purposes, or (2) anything designed or sold for incorporation"-    , "into a dwelling.  In determining whether a product is a consumer product,"-    , "doubtful cases shall be resolved in favor of coverage.  For a particular"-    , "product received by a particular user, \"normally used\" refers to a"-    , "typical or common use of that class of product, regardless of the status"-    , "of the particular user or of the way in which the particular user"-    , "actually uses, or expects or is expected to use, the product.  A product"-    , "is a consumer product regardless of whether the product has substantial"-    , "commercial, industrial or non-consumer uses, unless such uses represent"-    , "the only significant mode of use of the product."-    , ""-    , "  \"Installation Information\" for a User Product means any methods,"-    , "procedures, authorization keys, or other information required to install"-    , "and execute modified versions of a covered work in that User Product from"-    , "a modified version of its Corresponding Source.  The information must"-    , "suffice to ensure that the continued functioning of the modified object"-    , "code is in no case prevented or interfered with solely because"-    , "modification has been made."-    , ""-    , "  If you convey an object code work under this section in, or with, or"-    , "specifically for use in, a User Product, and the conveying occurs as"-    , "part of a transaction in which the right of possession and use of the"-    , "User Product is transferred to the recipient in perpetuity or for a"-    , "fixed term (regardless of how the transaction is characterized), the"-    , "Corresponding Source conveyed under this section must be accompanied"-    , "by the Installation Information.  But this requirement does not apply"-    , "if neither you nor any third party retains the ability to install"-    , "modified object code on the User Product (for example, the work has"-    , "been installed in ROM)."-    , ""-    , "  The requirement to provide Installation Information does not include a"-    , "requirement to continue to provide support service, warranty, or updates"-    , "for a work that has been modified or installed by the recipient, or for"-    , "the User Product in which it has been modified or installed.  Access to a"-    , "network may be denied when the modification itself materially and"-    , "adversely affects the operation of the network or violates the rules and"-    , "protocols for communication across the network."-    , ""-    , "  Corresponding Source conveyed, and Installation Information provided,"-    , "in accord with this section must be in a format that is publicly"-    , "documented (and with an implementation available to the public in"-    , "source code form), and must require no special password or key for"-    , "unpacking, reading or copying."-    , ""-    , "  7. Additional Terms."-    , ""-    , "  \"Additional permissions\" are terms that supplement the terms of this"-    , "License by making exceptions from one or more of its conditions."-    , "Additional permissions that are applicable to the entire Program shall"-    , "be treated as though they were included in this License, to the extent"-    , "that they are valid under applicable law.  If additional permissions"-    , "apply only to part of the Program, that part may be used separately"-    , "under those permissions, but the entire Program remains governed by"-    , "this License without regard to the additional permissions."-    , ""-    , "  When you convey a copy of a covered work, you may at your option"-    , "remove any additional permissions from that copy, or from any part of"-    , "it.  (Additional permissions may be written to require their own"-    , "removal in certain cases when you modify the work.)  You may place"-    , "additional permissions on material, added by you to a covered work,"-    , "for which you have or can give appropriate copyright permission."-    , ""-    , "  Notwithstanding any other provision of this License, for material you"-    , "add to a covered work, you may (if authorized by the copyright holders of"-    , "that material) supplement the terms of this License with terms:"-    , ""-    , "    a) Disclaiming warranty or limiting liability differently from the"-    , "    terms of sections 15 and 16 of this License; or"-    , ""-    , "    b) Requiring preservation of specified reasonable legal notices or"-    , "    author attributions in that material or in the Appropriate Legal"-    , "    Notices displayed by works containing it; or"-    , ""-    , "    c) Prohibiting misrepresentation of the origin of that material, or"-    , "    requiring that modified versions of such material be marked in"-    , "    reasonable ways as different from the original version; or"-    , ""-    , "    d) Limiting the use for publicity purposes of names of licensors or"-    , "    authors of the material; or"-    , ""-    , "    e) Declining to grant rights under trademark law for use of some"-    , "    trade names, trademarks, or service marks; or"-    , ""-    , "    f) Requiring indemnification of licensors and authors of that"-    , "    material by anyone who conveys the material (or modified versions of"-    , "    it) with contractual assumptions of liability to the recipient, for"-    , "    any liability that these contractual assumptions directly impose on"-    , "    those licensors and authors."-    , ""-    , "  All other non-permissive additional terms are considered \"further"-    , "restrictions\" within the meaning of section 10.  If the Program as you"-    , "received it, or any part of it, contains a notice stating that it is"-    , "governed by this License along with a term that is a further"-    , "restriction, you may remove that term.  If a license document contains"-    , "a further restriction but permits relicensing or conveying under this"-    , "License, you may add to a covered work material governed by the terms"-    , "of that license document, provided that the further restriction does"-    , "not survive such relicensing or conveying."-    , ""-    , "  If you add terms to a covered work in accord with this section, you"-    , "must place, in the relevant source files, a statement of the"-    , "additional terms that apply to those files, or a notice indicating"-    , "where to find the applicable terms."-    , ""-    , "  Additional terms, permissive or non-permissive, may be stated in the"-    , "form of a separately written license, or stated as exceptions;"-    , "the above requirements apply either way."-    , ""-    , "  8. Termination."-    , ""-    , "  You may not propagate or modify a covered work except as expressly"-    , "provided under this License.  Any attempt otherwise to propagate or"-    , "modify it is void, and will automatically terminate your rights under"-    , "this License (including any patent licenses granted under the third"-    , "paragraph of section 11)."-    , ""-    , "  However, if you cease all violation of this License, then your"-    , "license from a particular copyright holder is reinstated (a)"-    , "provisionally, unless and until the copyright holder explicitly and"-    , "finally terminates your license, and (b) permanently, if the copyright"-    , "holder fails to notify you of the violation by some reasonable means"-    , "prior to 60 days after the cessation."-    , ""-    , "  Moreover, your license from a particular copyright holder is"-    , "reinstated permanently if the copyright holder notifies you of the"-    , "violation by some reasonable means, this is the first time you have"-    , "received notice of violation of this License (for any work) from that"-    , "copyright holder, and you cure the violation prior to 30 days after"-    , "your receipt of the notice."-    , ""-    , "  Termination of your rights under this section does not terminate the"-    , "licenses of parties who have received copies or rights from you under"-    , "this License.  If your rights have been terminated and not permanently"-    , "reinstated, you do not qualify to receive new licenses for the same"-    , "material under section 10."-    , ""-    , "  9. Acceptance Not Required for Having Copies."-    , ""-    , "  You are not required to accept this License in order to receive or"-    , "run a copy of the Program.  Ancillary propagation of a covered work"-    , "occurring solely as a consequence of using peer-to-peer transmission"-    , "to receive a copy likewise does not require acceptance.  However,"-    , "nothing other than this License grants you permission to propagate or"-    , "modify any covered work.  These actions infringe copyright if you do"-    , "not accept this License.  Therefore, by modifying or propagating a"-    , "covered work, you indicate your acceptance of this License to do so."-    , ""-    , "  10. Automatic Licensing of Downstream Recipients."-    , ""-    , "  Each time you convey a covered work, the recipient automatically"-    , "receives a license from the original licensors, to run, modify and"-    , "propagate that work, subject to this License.  You are not responsible"-    , "for enforcing compliance by third parties with this License."-    , ""-    , "  An \"entity transaction\" is a transaction transferring control of an"-    , "organization, or substantially all assets of one, or subdividing an"-    , "organization, or merging organizations.  If propagation of a covered"-    , "work results from an entity transaction, each party to that"-    , "transaction who receives a copy of the work also receives whatever"-    , "licenses to the work the party's predecessor in interest had or could"-    , "give under the previous paragraph, plus a right to possession of the"-    , "Corresponding Source of the work from the predecessor in interest, if"-    , "the predecessor has it or can get it with reasonable efforts."-    , ""-    , "  You may not impose any further restrictions on the exercise of the"-    , "rights granted or affirmed under this License.  For example, you may"-    , "not impose a license fee, royalty, or other charge for exercise of"-    , "rights granted under this License, and you may not initiate litigation"-    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"-    , "any patent claim is infringed by making, using, selling, offering for"-    , "sale, or importing the Program or any portion of it."-    , ""-    , "  11. Patents."-    , ""-    , "  A \"contributor\" is a copyright holder who authorizes use under this"-    , "License of the Program or a work on which the Program is based.  The"-    , "work thus licensed is called the contributor's \"contributor version\"."-    , ""-    , "  A contributor's \"essential patent claims\" are all patent claims"-    , "owned or controlled by the contributor, whether already acquired or"-    , "hereafter acquired, that would be infringed by some manner, permitted"-    , "by this License, of making, using, or selling its contributor version,"-    , "but do not include claims that would be infringed only as a"-    , "consequence of further modification of the contributor version.  For"-    , "purposes of this definition, \"control\" includes the right to grant"-    , "patent sublicenses in a manner consistent with the requirements of"-    , "this License."-    , ""-    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"-    , "patent license under the contributor's essential patent claims, to"-    , "make, use, sell, offer for sale, import and otherwise run, modify and"-    , "propagate the contents of its contributor version."-    , ""-    , "  In the following three paragraphs, a \"patent license\" is any express"-    , "agreement or commitment, however denominated, not to enforce a patent"-    , "(such as an express permission to practice a patent or covenant not to"-    , "sue for patent infringement).  To \"grant\" such a patent license to a"-    , "party means to make such an agreement or commitment not to enforce a"-    , "patent against the party."-    , ""-    , "  If you convey a covered work, knowingly relying on a patent license,"-    , "and the Corresponding Source of the work is not available for anyone"-    , "to copy, free of charge and under the terms of this License, through a"-    , "publicly available network server or other readily accessible means,"-    , "then you must either (1) cause the Corresponding Source to be so"-    , "available, or (2) arrange to deprive yourself of the benefit of the"-    , "patent license for this particular work, or (3) arrange, in a manner"-    , "consistent with the requirements of this License, to extend the patent"-    , "license to downstream recipients.  \"Knowingly relying\" means you have"-    , "actual knowledge that, but for the patent license, your conveying the"-    , "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"-    , "receiving the covered work authorizing them to use, propagate, modify"-    , "or convey a specific copy of the covered work, then the patent license"-    , "you grant is automatically extended to all recipients of the covered"-    , "work and works based on it."-    , ""-    , "  A patent license is \"discriminatory\" if it does not include within"-    , "the scope of its coverage, prohibits the exercise of, or is"-    , "conditioned on the non-exercise of one or more of the rights that are"-    , "specifically granted under this License.  You may not convey a covered"-    , "work if you are a party to an arrangement with a third party that is"-    , "in the business of distributing software, under which you make payment"-    , "to the third party based on the extent of your activity of conveying"-    , "the work, and under which the third party grants, to any of the"-    , "parties who would receive the covered work from you, a discriminatory"-    , "patent license (a) in connection with copies of the covered work"-    , "conveyed by you (or copies made from those copies), or (b) primarily"-    , "for and in connection with specific products or compilations that"-    , "contain the covered work, unless you entered into that arrangement,"-    , "or that patent license was granted, prior to 28 March 2007."-    , ""-    , "  Nothing in this License shall be construed as excluding or limiting"-    , "any implied license or other defenses to infringement that may"-    , "otherwise be available to you under applicable patent law."-    , ""-    , "  12. No Surrender of Others' Freedom."-    , ""-    , "  If conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot convey a"-    , "covered work so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you may"-    , "not convey it at all.  For example, if you agree to terms that obligate you"-    , "to collect a royalty for further conveying from those to whom you convey"-    , "the Program, the only way you could satisfy both those terms and this"-    , "License would be to refrain entirely from conveying the Program."-    , ""-    , "  13. Use with the GNU Affero General Public License."-    , ""-    , "  Notwithstanding any other provision of this License, you have"-    , "permission to link or combine any covered work with a work licensed"-    , "under version 3 of the GNU Affero General Public License into a single"-    , "combined work, and to convey the resulting work.  The terms of this"-    , "License will continue to apply to the part which is the covered work,"-    , "but the special requirements of the GNU Affero General Public License,"-    , "section 13, concerning interaction through a network will apply to the"-    , "combination as such."-    , ""-    , "  14. Revised Versions of this License."-    , ""-    , "  The Free Software Foundation may publish revised and/or new versions of"-    , "the GNU 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."-    , ""-    , "  Each version is given a distinguishing version number.  If the"-    , "Program specifies that a certain numbered version of the GNU General"-    , "Public License \"or any later version\" applies to it, you have the"-    , "option of following the terms and conditions either of that numbered"-    , "version or of any later version published by the Free Software"-    , "Foundation.  If the Program does not specify a version number of the"-    , "GNU General Public License, you may choose any version ever published"-    , "by the Free Software Foundation."-    , ""-    , "  If the Program specifies that a proxy can decide which future"-    , "versions of the GNU General Public License can be used, that proxy's"-    , "public statement of acceptance of a version permanently authorizes you"-    , "to choose that version for the Program."-    , ""-    , "  Later license versions may give you additional or different"-    , "permissions.  However, no additional obligations are imposed on any"-    , "author or copyright holder as a result of your choosing to follow a"-    , "later version."-    , ""-    , "  15. Disclaimer of Warranty."-    , ""-    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"-    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"-    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"-    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"-    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"-    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"-    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"-    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."-    , ""-    , "  16. Limitation of Liability."-    , ""-    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"-    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"-    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"-    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"-    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"-    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"-    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"-    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"-    , "SUCH DAMAGES."-    , ""-    , "  17. Interpretation of Sections 15 and 16."-    , ""-    , "  If the disclaimer of warranty and limitation of liability provided"-    , "above cannot be given local legal effect according to their terms,"-    , "reviewing courts shall apply local law that most closely approximates"-    , "an absolute waiver of all civil liability in connection with the"-    , "Program, unless a warranty or assumption of liability accompanies a"-    , "copy of the Program in return for a fee."-    , ""-    , "              END OF TERMS AND CONDITIONS"-    , ""-    , "     How to Apply These Terms to Your New Programs"-    , ""-    , "  If you develop a new program, and you want it to be of the greatest"-    , "possible use to the public, the best way to achieve this is to make it"-    , "free software which everyone can redistribute and change under these terms."-    , ""-    , "  To do so, attach the following notices to the program.  It is safest"-    , "to attach them to the start of each source file to most effectively"-    , "state the exclusion of warranty; and each file should have at least"-    , "the \"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the program's name and a brief idea of what it does.>"-    , "    Copyright (C) <year>  <name of author>"-    , ""-    , "    This program is free software: you can redistribute it and/or modify"-    , "    it under the terms of the GNU General Public License as published by"-    , "    the Free Software Foundation, either version 3 of the License, or"-    , "    (at your option) any later version."-    , ""-    , "    This program 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 General Public License for more details."-    , ""-    , "    You should have received a copy of the GNU General Public License"-    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."-    , ""-    , "Also add information on how to contact you by electronic and paper mail."-    , ""-    , "  If the program does terminal interaction, make it output a short"-    , "notice like this when it starts in an interactive mode:"-    , ""-    , "    <program>  Copyright (C) <year>  <name of author>"-    , "    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'."-    , "    This is free software, and you are welcome to redistribute it"-    , "    under certain conditions; type `show c' for details."-    , ""-    , "The hypothetical commands `show w' and `show c' should show the appropriate"-    , "parts of the General Public License.  Of course, your program's commands"-    , "might be different; for a GUI interface, you would use an \"about box\"."-    , ""-    , "  You should also get your employer (if you work as a programmer) or school,"-    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."-    , "For more information on this, and how to apply and follow the GNU GPL, see"-    , "<http://www.gnu.org/licenses/>."-    , ""-    , "  The GNU General Public License does not permit incorporating your program"-    , "into proprietary programs.  If your program is a subroutine library, you"-    , "may consider it more useful to permit linking proprietary applications with"-    , "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-agplv3 = unlines-    [ "                    GNU AFFERO GENERAL PUBLIC LICENSE"-    , "                       Version 3, 19 November 2007"-    , ""-    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , "                            Preamble"-    , ""-    , "  The GNU Affero General Public License is a free, copyleft license for"-    , "software and other kinds of works, specifically designed to ensure"-    , "cooperation with the community in the case of network server software."-    , ""-    , "  The licenses for most software and other practical works are designed"-    , "to take away your freedom to share and change the works.  By contrast,"-    , "our General Public Licenses are intended to guarantee your freedom to"-    , "share and change all versions of a program--to make sure it remains free"-    , "software for all its users."-    , ""-    , "  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"-    , "them 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."-    , ""-    , "  Developers that use our General Public Licenses protect your rights"-    , "with two steps: (1) assert copyright on the software, and (2) offer"-    , "you this License which gives you legal permission to copy, distribute"-    , "and/or modify the software."-    , ""-    , "  A secondary benefit of defending all users' freedom is that"-    , "improvements made in alternate versions of the program, if they"-    , "receive widespread use, become available for other developers to"-    , "incorporate.  Many developers of free software are heartened and"-    , "encouraged by the resulting cooperation.  However, in the case of"-    , "software used on network servers, this result may fail to come about."-    , "The GNU General Public License permits making a modified version and"-    , "letting the public access it on a server without ever releasing its"-    , "source code to the public."-    , ""-    , "  The GNU Affero General Public License is designed specifically to"-    , "ensure that, in such cases, the modified source code becomes available"-    , "to the community.  It requires the operator of a network server to"-    , "provide the source code of the modified version running there to the"-    , "users of that server.  Therefore, public use of a modified version, on"-    , "a publicly accessible server, gives the public access to the source"-    , "code of the modified version."-    , ""-    , "  An older license, called the Affero General Public License and"-    , "published by Affero, was designed to accomplish similar goals.  This is"-    , "a different license, not a version of the Affero GPL, but Affero has"-    , "released a new version of the Affero GPL which permits relicensing under"-    , "this license."-    , ""-    , "  The precise terms and conditions for copying, distribution and"-    , "modification follow."-    , ""-    , "                       TERMS AND CONDITIONS"-    , ""-    , "  0. Definitions."-    , ""-    , "  \"This License\" refers to version 3 of the GNU Affero General Public License."-    , ""-    , "  \"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."-    , ""-    , "  To \"modify\" a work means to copy from or adapt all or part of the work"-    , "in a fashion requiring copyright permission, other than the making of an"-    , "exact copy.  The resulting work is called a \"modified version\" of the"-    , "earlier work or a work \"based on\" the earlier work."-    , ""-    , "  A \"covered work\" means either the unmodified Program or a work based"-    , "on the Program."-    , ""-    , "  To \"propagate\" a work means to do anything with it that, without"-    , "permission, would make you directly or secondarily liable for"-    , "infringement under applicable copyright law, except executing it on a"-    , "computer or modifying a private copy.  Propagation includes copying,"-    , "distribution (with or without modification), making available to the"-    , "public, and in some countries other activities as well."-    , ""-    , "  To \"convey\" a work means any kind of propagation that enables other"-    , "parties to make or receive copies.  Mere interaction with a user through"-    , "a computer network, with no transfer of a copy, is not conveying."-    , ""-    , "  An interactive user interface displays \"Appropriate Legal Notices\""-    , "to the extent that it includes a convenient and prominently visible"-    , "feature that (1) displays an appropriate copyright notice, and (2)"-    , "tells the user that there is no warranty for the work (except to the"-    , "extent that warranties are provided), that licensees may convey the"-    , "work under this License, and how to view a copy of this License.  If"-    , "the interface presents a list of user commands or options, such as a"-    , "menu, a prominent item in the list meets this criterion."-    , ""-    , "  1. Source Code."-    , ""-    , "  The \"source code\" for a work means the preferred form of the work"-    , "for making modifications to it.  \"Object code\" means any non-source"-    , "form of a work."-    , ""-    , "  A \"Standard Interface\" means an interface that either is an official"-    , "standard defined by a recognized standards body, or, in the case of"-    , "interfaces specified for a particular programming language, one that"-    , "is widely used among developers working in that language."-    , ""-    , "  The \"System Libraries\" of an executable work include anything, other"-    , "than the work as a whole, that (a) is included in the normal form of"-    , "packaging a Major Component, but which is not part of that Major"-    , "Component, and (b) serves only to enable use of the work with that"-    , "Major Component, or to implement a Standard Interface for which an"-    , "implementation is available to the public in source code form.  A"-    , "\"Major Component\", in this context, means a major essential component"-    , "(kernel, window system, and so on) of the specific operating system"-    , "(if any) on which the executable work runs, or a compiler used to"-    , "produce the work, or an object code interpreter used to run it."-    , ""-    , "  The \"Corresponding Source\" for a work in object code form means all"-    , "the source code needed to generate, install, and (for an executable"-    , "work) run the object code and to modify the work, including scripts to"-    , "control those activities.  However, it does not include the work's"-    , "System Libraries, or general-purpose tools or generally available free"-    , "programs which are used unmodified in performing those activities but"-    , "which are not part of the work.  For example, Corresponding Source"-    , "includes interface definition files associated with source files for"-    , "the work, and the source code for shared libraries and dynamically"-    , "linked subprograms that the work is specifically designed to require,"-    , "such as by intimate data communication or control flow between those"-    , "subprograms and other parts of the work."-    , ""-    , "  The Corresponding Source need not include anything that users"-    , "can regenerate automatically from other parts of the Corresponding"-    , "Source."-    , ""-    , "  The Corresponding Source for a work in source code form is that"-    , "same work."-    , ""-    , "  2. Basic Permissions."-    , ""-    , "  All rights granted under this License are granted for the term of"-    , "copyright on the Program, and are irrevocable provided the stated"-    , "conditions are met.  This License explicitly affirms your unlimited"-    , "permission to run the unmodified Program.  The output from running a"-    , "covered work is covered by this License only if the output, given its"-    , "content, constitutes a covered work.  This License acknowledges your"-    , "rights of fair use or other equivalent, as provided by copyright law."-    , ""-    , "  You may make, run and propagate covered works that you do not"-    , "convey, without conditions so long as your license otherwise remains"-    , "in force.  You may convey covered works to others for the sole purpose"-    , "of having them make modifications exclusively for you, or provide you"-    , "with facilities for running those works, provided that you comply with"-    , "the terms of this License in conveying all material for which you do"-    , "not control copyright.  Those thus making or running the covered works"-    , "for you must do so exclusively on your behalf, under your direction"-    , "and control, on terms that prohibit them from making any copies of"-    , "your copyrighted material outside their relationship with you."-    , ""-    , "  Conveying under any other circumstances is permitted solely under"-    , "the conditions stated below.  Sublicensing is not allowed; section 10"-    , "makes it unnecessary."-    , ""-    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."-    , ""-    , "  No covered work shall be deemed part of an effective technological"-    , "measure under any applicable law fulfilling obligations under article"-    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"-    , "similar laws prohibiting or restricting circumvention of such"-    , "measures."-    , ""-    , "  When you convey a covered work, you waive any legal power to forbid"-    , "circumvention of technological measures to the extent such circumvention"-    , "is effected by exercising rights under this License with respect to"-    , "the covered work, and you disclaim any intention to limit operation or"-    , "modification of the work as a means of enforcing, against the work's"-    , "users, your or third parties' legal rights to forbid circumvention of"-    , "technological measures."-    , ""-    , "  4. Conveying Verbatim Copies."-    , ""-    , "  You may convey verbatim copies of the Program's source code as you"-    , "receive it, in any medium, provided that you conspicuously and"-    , "appropriately publish on each copy an appropriate copyright notice;"-    , "keep intact all notices stating that this License and any"-    , "non-permissive terms added in accord with section 7 apply to the code;"-    , "keep intact all notices of the absence of any warranty; and give all"-    , "recipients a copy of this License along with the Program."-    , ""-    , "  You may charge any price or no price for each copy that you convey,"-    , "and you may offer support or warranty protection for a fee."-    , ""-    , "  5. Conveying Modified Source Versions."-    , ""-    , "  You may convey a work based on the Program, or the modifications to"-    , "produce it from the Program, in the form of source code under the"-    , "terms of section 4, provided that you also meet all of these conditions:"-    , ""-    , "    a) The work must carry prominent notices stating that you modified"-    , "    it, and giving a relevant date."-    , ""-    , "    b) The work must carry prominent notices stating that it is"-    , "    released under this License and any conditions added under section"-    , "    7.  This requirement modifies the requirement in section 4 to"-    , "    \"keep intact all notices\"."-    , ""-    , "    c) You must license the entire work, as a whole, under this"-    , "    License to anyone who comes into possession of a copy.  This"-    , "    License will therefore apply, along with any applicable section 7"-    , "    additional terms, to the whole of the work, and all its parts,"-    , "    regardless of how they are packaged.  This License gives no"-    , "    permission to license the work in any other way, but it does not"-    , "    invalidate such permission if you have separately received it."-    , ""-    , "    d) If the work has interactive user interfaces, each must display"-    , "    Appropriate Legal Notices; however, if the Program has interactive"-    , "    interfaces that do not display Appropriate Legal Notices, your"-    , "    work need not make them do so."-    , ""-    , "  A compilation of a covered work with other separate and independent"-    , "works, which are not by their nature extensions of the covered work,"-    , "and which are not combined with it such as to form a larger program,"-    , "in or on a volume of a storage or distribution medium, is called an"-    , "\"aggregate\" if the compilation and its resulting copyright are not"-    , "used to limit the access or legal rights of the compilation's users"-    , "beyond what the individual works permit.  Inclusion of a covered work"-    , "in an aggregate does not cause this License to apply to the other"-    , "parts of the aggregate."-    , ""-    , "  6. Conveying Non-Source Forms."-    , ""-    , "  You may convey a covered work in object code form under the terms"-    , "of sections 4 and 5, provided that you also convey the"-    , "machine-readable Corresponding Source under the terms of this License,"-    , "in one of these ways:"-    , ""-    , "    a) Convey the object code in, or embodied in, a physical product"-    , "    (including a physical distribution medium), accompanied by the"-    , "    Corresponding Source fixed on a durable physical medium"-    , "    customarily used for software interchange."-    , ""-    , "    b) Convey the object code in, or embodied in, a physical product"-    , "    (including a physical distribution medium), accompanied by a"-    , "    written offer, valid for at least three years and valid for as"-    , "    long as you offer spare parts or customer support for that product"-    , "    model, to give anyone who possesses the object code either (1) a"-    , "    copy of the Corresponding Source for all the software in the"-    , "    product that is covered by this License, on a durable physical"-    , "    medium customarily used for software interchange, for a price no"-    , "    more than your reasonable cost of physically performing this"-    , "    conveying of source, or (2) access to copy the"-    , "    Corresponding Source from a network server at no charge."-    , ""-    , "    c) Convey individual copies of the object code with a copy of the"-    , "    written offer to provide the Corresponding Source.  This"-    , "    alternative is allowed only occasionally and noncommercially, and"-    , "    only if you received the object code with such an offer, in accord"-    , "    with subsection 6b."-    , ""-    , "    d) Convey the object code by offering access from a designated"-    , "    place (gratis or for a charge), and offer equivalent access to the"-    , "    Corresponding Source in the same way through the same place at no"-    , "    further charge.  You need not require recipients to copy the"-    , "    Corresponding Source along with the object code.  If the place to"-    , "    copy the object code is a network server, the Corresponding Source"-    , "    may be on a different server (operated by you or a third party)"-    , "    that supports equivalent copying facilities, provided you maintain"-    , "    clear directions next to the object code saying where to find the"-    , "    Corresponding Source.  Regardless of what server hosts the"-    , "    Corresponding Source, you remain obligated to ensure that it is"-    , "    available for as long as needed to satisfy these requirements."-    , ""-    , "    e) Convey the object code using peer-to-peer transmission, provided"-    , "    you inform other peers where the object code and Corresponding"-    , "    Source of the work are being offered to the general public at no"-    , "    charge under subsection 6d."-    , ""-    , "  A separable portion of the object code, whose source code is excluded"-    , "from the Corresponding Source as a System Library, need not be"-    , "included in conveying the object code work."-    , ""-    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"-    , "tangible personal property which is normally used for personal, family,"-    , "or household purposes, or (2) anything designed or sold for incorporation"-    , "into a dwelling.  In determining whether a product is a consumer product,"-    , "doubtful cases shall be resolved in favor of coverage.  For a particular"-    , "product received by a particular user, \"normally used\" refers to a"-    , "typical or common use of that class of product, regardless of the status"-    , "of the particular user or of the way in which the particular user"-    , "actually uses, or expects or is expected to use, the product.  A product"-    , "is a consumer product regardless of whether the product has substantial"-    , "commercial, industrial or non-consumer uses, unless such uses represent"-    , "the only significant mode of use of the product."-    , ""-    , "  \"Installation Information\" for a User Product means any methods,"-    , "procedures, authorization keys, or other information required to install"-    , "and execute modified versions of a covered work in that User Product from"-    , "a modified version of its Corresponding Source.  The information must"-    , "suffice to ensure that the continued functioning of the modified object"-    , "code is in no case prevented or interfered with solely because"-    , "modification has been made."-    , ""-    , "  If you convey an object code work under this section in, or with, or"-    , "specifically for use in, a User Product, and the conveying occurs as"-    , "part of a transaction in which the right of possession and use of the"-    , "User Product is transferred to the recipient in perpetuity or for a"-    , "fixed term (regardless of how the transaction is characterized), the"-    , "Corresponding Source conveyed under this section must be accompanied"-    , "by the Installation Information.  But this requirement does not apply"-    , "if neither you nor any third party retains the ability to install"-    , "modified object code on the User Product (for example, the work has"-    , "been installed in ROM)."-    , ""-    , "  The requirement to provide Installation Information does not include a"-    , "requirement to continue to provide support service, warranty, or updates"-    , "for a work that has been modified or installed by the recipient, or for"-    , "the User Product in which it has been modified or installed.  Access to a"-    , "network may be denied when the modification itself materially and"-    , "adversely affects the operation of the network or violates the rules and"-    , "protocols for communication across the network."-    , ""-    , "  Corresponding Source conveyed, and Installation Information provided,"-    , "in accord with this section must be in a format that is publicly"-    , "documented (and with an implementation available to the public in"-    , "source code form), and must require no special password or key for"-    , "unpacking, reading or copying."-    , ""-    , "  7. Additional Terms."-    , ""-    , "  \"Additional permissions\" are terms that supplement the terms of this"-    , "License by making exceptions from one or more of its conditions."-    , "Additional permissions that are applicable to the entire Program shall"-    , "be treated as though they were included in this License, to the extent"-    , "that they are valid under applicable law.  If additional permissions"-    , "apply only to part of the Program, that part may be used separately"-    , "under those permissions, but the entire Program remains governed by"-    , "this License without regard to the additional permissions."-    , ""-    , "  When you convey a copy of a covered work, you may at your option"-    , "remove any additional permissions from that copy, or from any part of"-    , "it.  (Additional permissions may be written to require their own"-    , "removal in certain cases when you modify the work.)  You may place"-    , "additional permissions on material, added by you to a covered work,"-    , "for which you have or can give appropriate copyright permission."-    , ""-    , "  Notwithstanding any other provision of this License, for material you"-    , "add to a covered work, you may (if authorized by the copyright holders of"-    , "that material) supplement the terms of this License with terms:"-    , ""-    , "    a) Disclaiming warranty or limiting liability differently from the"-    , "    terms of sections 15 and 16 of this License; or"-    , ""-    , "    b) Requiring preservation of specified reasonable legal notices or"-    , "    author attributions in that material or in the Appropriate Legal"-    , "    Notices displayed by works containing it; or"-    , ""-    , "    c) Prohibiting misrepresentation of the origin of that material, or"-    , "    requiring that modified versions of such material be marked in"-    , "    reasonable ways as different from the original version; or"-    , ""-    , "    d) Limiting the use for publicity purposes of names of licensors or"-    , "    authors of the material; or"-    , ""-    , "    e) Declining to grant rights under trademark law for use of some"-    , "    trade names, trademarks, or service marks; or"-    , ""-    , "    f) Requiring indemnification of licensors and authors of that"-    , "    material by anyone who conveys the material (or modified versions of"-    , "    it) with contractual assumptions of liability to the recipient, for"-    , "    any liability that these contractual assumptions directly impose on"-    , "    those licensors and authors."-    , ""-    , "  All other non-permissive additional terms are considered \"further"-    , "restrictions\" within the meaning of section 10.  If the Program as you"-    , "received it, or any part of it, contains a notice stating that it is"-    , "governed by this License along with a term that is a further"-    , "restriction, you may remove that term.  If a license document contains"-    , "a further restriction but permits relicensing or conveying under this"-    , "License, you may add to a covered work material governed by the terms"-    , "of that license document, provided that the further restriction does"-    , "not survive such relicensing or conveying."-    , ""-    , "  If you add terms to a covered work in accord with this section, you"-    , "must place, in the relevant source files, a statement of the"-    , "additional terms that apply to those files, or a notice indicating"-    , "where to find the applicable terms."-    , ""-    , "  Additional terms, permissive or non-permissive, may be stated in the"-    , "form of a separately written license, or stated as exceptions;"-    , "the above requirements apply either way."-    , ""-    , "  8. Termination."-    , ""-    , "  You may not propagate or modify a covered work except as expressly"-    , "provided under this License.  Any attempt otherwise to propagate or"-    , "modify it is void, and will automatically terminate your rights under"-    , "this License (including any patent licenses granted under the third"-    , "paragraph of section 11)."-    , ""-    , "  However, if you cease all violation of this License, then your"-    , "license from a particular copyright holder is reinstated (a)"-    , "provisionally, unless and until the copyright holder explicitly and"-    , "finally terminates your license, and (b) permanently, if the copyright"-    , "holder fails to notify you of the violation by some reasonable means"-    , "prior to 60 days after the cessation."-    , ""-    , "  Moreover, your license from a particular copyright holder is"-    , "reinstated permanently if the copyright holder notifies you of the"-    , "violation by some reasonable means, this is the first time you have"-    , "received notice of violation of this License (for any work) from that"-    , "copyright holder, and you cure the violation prior to 30 days after"-    , "your receipt of the notice."-    , ""-    , "  Termination of your rights under this section does not terminate the"-    , "licenses of parties who have received copies or rights from you under"-    , "this License.  If your rights have been terminated and not permanently"-    , "reinstated, you do not qualify to receive new licenses for the same"-    , "material under section 10."-    , ""-    , "  9. Acceptance Not Required for Having Copies."-    , ""-    , "  You are not required to accept this License in order to receive or"-    , "run a copy of the Program.  Ancillary propagation of a covered work"-    , "occurring solely as a consequence of using peer-to-peer transmission"-    , "to receive a copy likewise does not require acceptance.  However,"-    , "nothing other than this License grants you permission to propagate or"-    , "modify any covered work.  These actions infringe copyright if you do"-    , "not accept this License.  Therefore, by modifying or propagating a"-    , "covered work, you indicate your acceptance of this License to do so."-    , ""-    , "  10. Automatic Licensing of Downstream Recipients."-    , ""-    , "  Each time you convey a covered work, the recipient automatically"-    , "receives a license from the original licensors, to run, modify and"-    , "propagate that work, subject to this License.  You are not responsible"-    , "for enforcing compliance by third parties with this License."-    , ""-    , "  An \"entity transaction\" is a transaction transferring control of an"-    , "organization, or substantially all assets of one, or subdividing an"-    , "organization, or merging organizations.  If propagation of a covered"-    , "work results from an entity transaction, each party to that"-    , "transaction who receives a copy of the work also receives whatever"-    , "licenses to the work the party's predecessor in interest had or could"-    , "give under the previous paragraph, plus a right to possession of the"-    , "Corresponding Source of the work from the predecessor in interest, if"-    , "the predecessor has it or can get it with reasonable efforts."-    , ""-    , "  You may not impose any further restrictions on the exercise of the"-    , "rights granted or affirmed under this License.  For example, you may"-    , "not impose a license fee, royalty, or other charge for exercise of"-    , "rights granted under this License, and you may not initiate litigation"-    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"-    , "any patent claim is infringed by making, using, selling, offering for"-    , "sale, or importing the Program or any portion of it."-    , ""-    , "  11. Patents."-    , ""-    , "  A \"contributor\" is a copyright holder who authorizes use under this"-    , "License of the Program or a work on which the Program is based.  The"-    , "work thus licensed is called the contributor's \"contributor version\"."-    , ""-    , "  A contributor's \"essential patent claims\" are all patent claims"-    , "owned or controlled by the contributor, whether already acquired or"-    , "hereafter acquired, that would be infringed by some manner, permitted"-    , "by this License, of making, using, or selling its contributor version,"-    , "but do not include claims that would be infringed only as a"-    , "consequence of further modification of the contributor version.  For"-    , "purposes of this definition, \"control\" includes the right to grant"-    , "patent sublicenses in a manner consistent with the requirements of"-    , "this License."-    , ""-    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"-    , "patent license under the contributor's essential patent claims, to"-    , "make, use, sell, offer for sale, import and otherwise run, modify and"-    , "propagate the contents of its contributor version."-    , ""-    , "  In the following three paragraphs, a \"patent license\" is any express"-    , "agreement or commitment, however denominated, not to enforce a patent"-    , "(such as an express permission to practice a patent or covenant not to"-    , "sue for patent infringement).  To \"grant\" such a patent license to a"-    , "party means to make such an agreement or commitment not to enforce a"-    , "patent against the party."-    , ""-    , "  If you convey a covered work, knowingly relying on a patent license,"-    , "and the Corresponding Source of the work is not available for anyone"-    , "to copy, free of charge and under the terms of this License, through a"-    , "publicly available network server or other readily accessible means,"-    , "then you must either (1) cause the Corresponding Source to be so"-    , "available, or (2) arrange to deprive yourself of the benefit of the"-    , "patent license for this particular work, or (3) arrange, in a manner"-    , "consistent with the requirements of this License, to extend the patent"-    , "license to downstream recipients.  \"Knowingly relying\" means you have"-    , "actual knowledge that, but for the patent license, your conveying the"-    , "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"-    , "receiving the covered work authorizing them to use, propagate, modify"-    , "or convey a specific copy of the covered work, then the patent license"-    , "you grant is automatically extended to all recipients of the covered"-    , "work and works based on it."-    , ""-    , "  A patent license is \"discriminatory\" if it does not include within"-    , "the scope of its coverage, prohibits the exercise of, or is"-    , "conditioned on the non-exercise of one or more of the rights that are"-    , "specifically granted under this License.  You may not convey a covered"-    , "work if you are a party to an arrangement with a third party that is"-    , "in the business of distributing software, under which you make payment"-    , "to the third party based on the extent of your activity of conveying"-    , "the work, and under which the third party grants, to any of the"-    , "parties who would receive the covered work from you, a discriminatory"-    , "patent license (a) in connection with copies of the covered work"-    , "conveyed by you (or copies made from those copies), or (b) primarily"-    , "for and in connection with specific products or compilations that"-    , "contain the covered work, unless you entered into that arrangement,"-    , "or that patent license was granted, prior to 28 March 2007."-    , ""-    , "  Nothing in this License shall be construed as excluding or limiting"-    , "any implied license or other defenses to infringement that may"-    , "otherwise be available to you under applicable patent law."-    , ""-    , "  12. No Surrender of Others' Freedom."-    , ""-    , "  If conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot convey a"-    , "covered work so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you may"-    , "not convey it at all.  For example, if you agree to terms that obligate you"-    , "to collect a royalty for further conveying from those to whom you convey"-    , "the Program, the only way you could satisfy both those terms and this"-    , "License would be to refrain entirely from conveying the Program."-    , ""-    , "  13. Remote Network Interaction; Use with the GNU General Public License."-    , ""-    , "  Notwithstanding any other provision of this License, if you modify the"-    , "Program, your modified version must prominently offer all users"-    , "interacting with it remotely through a computer network (if your version"-    , "supports such interaction) an opportunity to receive the Corresponding"-    , "Source of your version by providing access to the Corresponding Source"-    , "from a network server at no charge, through some standard or customary"-    , "means of facilitating copying of software.  This Corresponding Source"-    , "shall include the Corresponding Source for any work covered by version 3"-    , "of the GNU General Public License that is incorporated pursuant to the"-    , "following paragraph."-    , ""-    , "  Notwithstanding any other provision of this License, you have"-    , "permission to link or combine any covered work with a work licensed"-    , "under version 3 of the GNU General Public License into a single"-    , "combined work, and to convey the resulting work.  The terms of this"-    , "License will continue to apply to the part which is the covered work,"-    , "but the work with which it is combined will remain governed by version"-    , "3 of the GNU General Public License."-    , ""-    , "  14. Revised Versions of this License."-    , ""-    , "  The Free Software Foundation may publish revised and/or new versions of"-    , "the GNU Affero 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."-    , ""-    , "  Each version is given a distinguishing version number.  If the"-    , "Program specifies that a certain numbered version of the GNU Affero General"-    , "Public License \"or any later version\" applies to it, you have the"-    , "option of following the terms and conditions either of that numbered"-    , "version or of any later version published by the Free Software"-    , "Foundation.  If the Program does not specify a version number of the"-    , "GNU Affero General Public License, you may choose any version ever published"-    , "by the Free Software Foundation."-    , ""-    , "  If the Program specifies that a proxy can decide which future"-    , "versions of the GNU Affero General Public License can be used, that proxy's"-    , "public statement of acceptance of a version permanently authorizes you"-    , "to choose that version for the Program."-    , ""-    , "  Later license versions may give you additional or different"-    , "permissions.  However, no additional obligations are imposed on any"-    , "author or copyright holder as a result of your choosing to follow a"-    , "later version."-    , ""-    , "  15. Disclaimer of Warranty."-    , ""-    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"-    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"-    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"-    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"-    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"-    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"-    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"-    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."-    , ""-    , "  16. Limitation of Liability."-    , ""-    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"-    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"-    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"-    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"-    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"-    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"-    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"-    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"-    , "SUCH DAMAGES."-    , ""-    , "  17. Interpretation of Sections 15 and 16."-    , ""-    , "  If the disclaimer of warranty and limitation of liability provided"-    , "above cannot be given local legal effect according to their terms,"-    , "reviewing courts shall apply local law that most closely approximates"-    , "an absolute waiver of all civil liability in connection with the"-    , "Program, unless a warranty or assumption of liability accompanies a"-    , "copy of the Program in return for a fee."-    , ""-    , "                     END OF TERMS AND CONDITIONS"-    , ""-    , "            How to Apply These Terms to Your New Programs"-    , ""-    , "  If you develop a new program, and you want it to be of the greatest"-    , "possible use to the public, the best way to achieve this is to make it"-    , "free software which everyone can redistribute and change under these terms."-    , ""-    , "  To do so, attach the following notices to the program.  It is safest"-    , "to attach them to the start of each source file to most effectively"-    , "state the exclusion of warranty; and each file should have at least"-    , "the \"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the program's name and a brief idea of what it does.>"-    , "    Copyright (C) <year>  <name of author>"-    , ""-    , "    This program is free software: you can redistribute it and/or modify"-    , "    it under the terms of the GNU Affero General Public License as published by"-    , "    the Free Software Foundation, either version 3 of the License, or"-    , "    (at your option) any later version."-    , ""-    , "    This program 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 Affero General Public License for more details."-    , ""-    , "    You should have received a copy of the GNU Affero General Public License"-    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."-    , ""-    , "Also add information on how to contact you by electronic and paper mail."-    , ""-    , "  If your software can interact with users remotely through a computer"-    , "network, you should also make sure that it provides a way for users to"-    , "get its source.  For example, if your program is a web application, its"-    , "interface could display a \"Source\" link that leads users to an archive"-    , "of the code.  There are many ways you could offer source, and different"-    , "solutions will be better for different programs; see section 13 for the"-    , "specific requirements."-    , ""-    , "  You should also get your employer (if you work as a programmer) or school,"-    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."-    , "For more information on this, and how to apply and follow the GNU AGPL, see"-    , "<http://www.gnu.org/licenses/>."-    ]--lgpl21 :: License-lgpl21 = unlines-    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"-    , "                       Version 2.1, February 1999"-    , ""-    , " 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 Lesser GPL.  It also counts"-    , " as the successor of the GNU Library Public License, version 2, hence"-    , " the version number 2.1.]"-    , ""-    , "                            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 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 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"-    , "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 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."-    , ""-    , "  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."-    , ""-    , "  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, 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.  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."-    , ""-    , "  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."-    , ""-    , "  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."-    , ""-    , "  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, whereas the latter must"-    , "be combined with the library in order to run."-    , ""-    , "                  GNU LESSER GENERAL PUBLIC LICENSE"-    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"-    , ""-    , "  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"-    , "(which use some of those functions and data) to form executables."-    , ""-    , "  The \"Library\", below, refers to any such software library or work"-    , "which has been distributed under these terms.  A \"work based on the"-    , "Library\" means either the Library or any derivative work under"-    , "copyright law: that is to say, a work containing the Library or a"-    , "portion of it, either verbatim or with modifications and/or translated"-    , "straightforwardly into another language.  (Hereinafter, translation is"-    , "included without limitation in the term \"modification\".)"-    , ""-    , "  \"Source code\" for a work means the preferred form of the work for"-    , "making modifications to it.  For a library, complete source code means"-    , "all the source code for all modules it contains, plus any associated"-    , "interface definition files, plus the scripts used to control compilation"-    , "and installation of the library."-    , ""-    , "  Activities other than copying, distribution and modification are not"-    , "covered by this License; they are outside its scope.  The act of"-    , "running a program using the Library is not restricted, and output from"-    , "such a program is covered only if its contents constitute a work based"-    , "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"-    , "appropriate copyright notice and disclaimer of warranty; keep intact"-    , "all the notices that refer to this License and to the absence of any"-    , "warranty; and distribute a copy of this License along with the"-    , "Library."-    , ""-    , "  You may charge a fee for the physical act of transferring a copy,"-    , "and you may at your option offer warranty protection in exchange for a"-    , "fee."-    , ""-    , "  2. You may modify your copy or copies of the Library or any portion"-    , "of it, thus forming a work based on the Library, and copy and"-    , "distribute such modifications or work under the terms of Section 1"-    , "above, provided that you also meet all of these conditions:"-    , ""-    , "    a) The modified work must itself be a software library."-    , ""-    , "    b) You must cause the files modified to carry prominent notices"-    , "    stating that you changed the files and the date of any change."-    , ""-    , "    c) You must cause the whole of the work to be licensed at no"-    , "    charge to all third parties under the terms of this License."-    , ""-    , "    d) If a facility in the modified Library refers to a function or a"-    , "    table of data to be supplied by an application program that uses"-    , "    the facility, other than as an argument passed when the facility"-    , "    is invoked, then you must make a good faith effort to ensure that,"-    , "    in the event an application does not supply such function or"-    , "    table, the facility still operates, and performs whatever part of"-    , "    its purpose remains meaningful."-    , ""-    , "    (For example, a function in a library to compute square roots has"-    , "    a purpose that is entirely well-defined independent of the"-    , "    application.  Therefore, Subsection 2d requires that any"-    , "    application-supplied function or table used by this function must"-    , "    be optional: if the application does not supply it, the square"-    , "    root function must still compute square roots.)"-    , ""-    , "These requirements apply to the modified work as a whole.  If"-    , "identifiable sections of that work are not derived from the Library,"-    , "and can be reasonably considered independent and separate works in"-    , "themselves, then this License, and its terms, do not apply to those"-    , "sections when you distribute them as separate works.  But when you"-    , "distribute the same sections as part of a whole which is a work based"-    , "on the Library, the distribution of the whole must be on the terms of"-    , "this License, whose permissions for other licensees extend to the"-    , "entire whole, and thus to each and every part regardless of who wrote"-    , "it."-    , ""-    , "Thus, it is not the intent of this section to claim rights or contest"-    , "your rights to work written entirely by you; rather, the intent is to"-    , "exercise the right to control the distribution of derivative or"-    , "collective works based on the Library."-    , ""-    , "In addition, mere aggregation of another work not based on the Library"-    , "with the Library (or with a work based on the Library) on a volume of"-    , "a storage or distribution medium does not bring the other work under"-    , "the scope of this License."-    , ""-    , "  3. You may opt to apply the terms of the ordinary GNU General Public"-    , "License instead of this License to a given copy of the Library.  To do"-    , "this, you must alter all the notices that refer to this License, so"-    , "that they refer to the ordinary GNU General Public License, version 2,"-    , "instead of to this License.  (If a newer version than version 2 of the"-    , "ordinary GNU General Public License has appeared, then you can specify"-    , "that version instead if you wish.)  Do not make any other change in"-    , "these notices."-    , ""-    , "  Once this change is made in a given copy, it is irreversible for"-    , "that copy, so the ordinary GNU General Public License applies to all"-    , "subsequent copies and derivative works made from that copy."-    , ""-    , "  This option is useful when you wish to copy part of the code of"-    , "the Library into a program that is not a library."-    , ""-    , "  4. You may copy and distribute the Library (or a portion or"-    , "derivative of it, under Section 2) in object code or executable form"-    , "under the terms of Sections 1 and 2 above provided that you accompany"-    , "it with the complete corresponding machine-readable source code, which"-    , "must be distributed under the terms of Sections 1 and 2 above on a"-    , "medium customarily used for software interchange."-    , ""-    , "  If distribution of object code is made by offering access to copy"-    , "from a designated place, then offering equivalent access to copy the"-    , "source code from the same place satisfies the requirement to"-    , "distribute the source code, even though third parties are not"-    , "compelled to copy the source along with the object code."-    , ""-    , "  5. A program that contains no derivative of any portion of the"-    , "Library, but is designed to work with the Library by being compiled or"-    , "linked with it, is called a \"work that uses the Library\".  Such a"-    , "work, in isolation, is not a derivative work of the Library, and"-    , "therefore falls outside the scope of this License."-    , ""-    , "  However, linking a \"work that uses the Library\" with the Library"-    , "creates an executable that is a derivative of the Library (because it"-    , "contains portions of the Library), rather than a \"work that uses the"-    , "library\".  The executable is therefore covered by this License."-    , "Section 6 states terms for distribution of such executables."-    , ""-    , "  When a \"work that uses the Library\" uses material from a header file"-    , "that is part of the Library, the object code for the work may be a"-    , "derivative work of the Library even though the source code is not."-    , "Whether this is true is especially significant if the work can be"-    , "linked without the Library, or if the work is itself a library.  The"-    , "threshold for this to be true is not precisely defined by law."-    , ""-    , "  If such an object file uses only numerical parameters, data"-    , "structure layouts and accessors, and small macros and small inline"-    , "functions (ten lines or less in length), then the use of the object"-    , "file is unrestricted, regardless of whether it is legally a derivative"-    , "work.  (Executables containing this object code plus portions of the"-    , "Library will still fall under Section 6.)"-    , ""-    , "  Otherwise, if the work is a derivative of the Library, you may"-    , "distribute the object code for the work under the terms of Section 6."-    , "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 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"-    , "modification of the work for the customer's own use and reverse"-    , "engineering for debugging such modifications."-    , ""-    , "  You must give prominent notice with each copy of the work that the"-    , "Library is used in it and that the Library and its use are covered by"-    , "this License.  You must supply a copy of this License.  If the work"-    , "during execution displays copyright notices, you must include the"-    , "copyright notice for the Library among them, as well as a reference"-    , "directing the user to the copy of this License.  Also, you must do one"-    , "of these things:"-    , ""-    , "    a) Accompany the work with the complete corresponding"-    , "    machine-readable source code for the Library including whatever"-    , "    changes were used in the work (which must be distributed under"-    , "    Sections 1 and 2 above); and, if the work is an executable linked"-    , "    with the Library, with the complete machine-readable \"work that"-    , "    uses the Library\", as object code and/or source code, so that the"-    , "    user can modify the Library and then relink to produce a modified"-    , "    executable containing the modified Library.  (It is understood"-    , "    that the user who changes the contents of definitions files in the"-    , "    Library will not necessarily be able to recompile the application"-    , "    to use the modified definitions.)"-    , ""-    , "    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."-    , ""-    , "    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."-    , ""-    , "    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 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."-    , ""-    , "  It may happen that this requirement contradicts the license"-    , "restrictions of other proprietary libraries that do not normally"-    , "accompany the operating system.  Such a contradiction means you cannot"-    , "use both them and the Library together in an executable that you"-    , "distribute."-    , ""-    , "  7. You may place library facilities that are a work based on the"-    , "Library side-by-side in a single library together with other library"-    , "facilities not covered by this License, and distribute such a combined"-    , "library, provided that the separate distribution of the work based on"-    , "the Library and of the other library facilities is otherwise"-    , "permitted, and provided that you do these two things:"-    , ""-    , "    a) Accompany the combined library with a copy of the same work"-    , "    based on the Library, uncombined with any other library"-    , "    facilities.  This must be distributed under the terms of the"-    , "    Sections above."-    , ""-    , "    b) Give prominent notice with the combined library of the fact"-    , "    that part of it is a work based on the Library, and explaining"-    , "    where to find the accompanying uncombined form of the same work."-    , ""-    , "  8. You may not copy, modify, sublicense, link with, or distribute"-    , "the Library except as expressly provided under this License.  Any"-    , "attempt otherwise to copy, modify, sublicense, link with, or"-    , "distribute the Library is void, and will automatically terminate your"-    , "rights under this License.  However, parties who have received copies,"-    , "or rights, from you under this License will not have their licenses"-    , "terminated so long as such parties remain in full compliance."-    , ""-    , "  9. You are not required to accept this License, since you have not"-    , "signed it.  However, nothing else grants you permission to modify or"-    , "distribute the Library or its derivative works.  These actions are"-    , "prohibited by law if you do not accept this License.  Therefore, by"-    , "modifying or distributing the Library (or any work based on the"-    , "Library), you indicate your acceptance of this License to do so, and"-    , "all its terms and conditions for copying, distributing or modifying"-    , "the Library or works based on it."-    , ""-    , "  10. Each time you redistribute the Library (or any work based on the"-    , "Library), the recipient automatically receives a license from the"-    , "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 with"-    , "this License."-    , ""-    , "  11. If, as a consequence of a court judgment or allegation of patent"-    , "infringement or for any other reason (not limited to patent issues),"-    , "conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot"-    , "distribute so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you"-    , "may not distribute the Library at all.  For example, if a patent"-    , "license would not permit royalty-free redistribution of the Library by"-    , "all those who receive copies directly or indirectly through you, then"-    , "the only way you could satisfy both it and this License would be to"-    , "refrain entirely from distribution of the Library."-    , ""-    , "If any portion of this section is held invalid or unenforceable under any"-    , "particular circumstance, the balance of the section is intended to apply,"-    , "and the section as a whole is intended to apply in other circumstances."-    , ""-    , "It is not the purpose of this section to induce you to infringe any"-    , "patents or other property right claims or to contest validity of any"-    , "such claims; this section has the sole purpose of protecting the"-    , "integrity of the free software distribution system which is"-    , "implemented by public license practices.  Many people have made"-    , "generous contributions to the wide range of software distributed"-    , "through that system in reliance on consistent application of that"-    , "system; it is up to the author/donor to decide if he or she is willing"-    , "to distribute software through any other system and a licensee cannot"-    , "impose that choice."-    , ""-    , "This section is intended to make thoroughly clear what is believed to"-    , "be a consequence of the rest of this License."-    , ""-    , "  12. If the distribution and/or use of the Library is restricted in"-    , "certain countries either by patents or by copyrighted interfaces, the"-    , "original copyright holder who places the Library under this License may add"-    , "an explicit geographical distribution limitation excluding those countries,"-    , "so that distribution is permitted only in or among countries not thus"-    , "excluded.  In such case, this License incorporates the limitation as if"-    , "written in the body of this License."-    , ""-    , "  13. The Free Software Foundation may publish revised and/or new"-    , "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."-    , ""-    , "Each version is given a distinguishing version number.  If the Library"-    , "specifies a version number of this License which applies to it and"-    , "\"any later version\", you have the option of following the terms and"-    , "conditions either of that version or of any later version published by"-    , "the Free Software Foundation.  If the Library does not specify a"-    , "license version number, you may choose any version ever published by"-    , "the Free Software Foundation."-    , ""-    , "  14. If you wish to incorporate parts of the Library into other free"-    , "programs whose distribution conditions are incompatible with these,"-    , "write to the author to ask for permission.  For software which is"-    , "copyrighted by the Free Software Foundation, write to the Free"-    , "Software Foundation; we sometimes make exceptions for this.  Our"-    , "decision will be guided by the two goals of preserving the free status"-    , "of all derivatives of our free software and of promoting the sharing"-    , "and reuse of software generally."-    , ""-    , "                            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."-    , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR"-    , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY"-    , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE"-    , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"-    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE"-    , "LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME"-    , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION."-    , ""-    , "  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN"-    , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY"-    , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU"-    , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR"-    , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE"-    , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING"-    , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A"-    , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF"-    , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"-    , "DAMAGES."-    , ""-    , "                     END OF TERMS AND CONDITIONS"-    , ""-    , "           How to Apply These Terms to Your New Libraries"-    , ""-    , "  If you develop a new library, and you want it to be of the greatest"-    , "possible use to the public, we recommend making it free software that"-    , "everyone can redistribute and change.  You can do so by permitting"-    , "redistribution under these terms (or, alternatively, under the terms of the"-    , "ordinary General Public License)."-    , ""-    , "  To apply these terms, attach the following notices to the library.  It is"-    , "safest to attach them to the start of each source file to most effectively"-    , "convey the exclusion of warranty; and each file should have at least the"-    , "\"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the library's name and a brief idea of what it does.>"-    , "    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 Lesser General Public"-    , "    License as published by the Free Software Foundation; either"-    , "    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"-    , "    Lesser General Public License for more details."-    , ""-    , "    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."-    , ""-    , "You should also get your employer (if you work as a programmer) or your"-    , "school, if any, to sign a \"copyright disclaimer\" for the library, if"-    , "necessary.  Here is a sample; alter the names:"-    , ""-    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the"-    , "  library `Frob' (a library for tweaking knobs) written by James Random Hacker."-    , ""-    , "  <signature of Ty Coon>, 1 April 1990"-    , "  Ty Coon, President of Vice"-    , ""-    , "That's all there is to it!"-    ]--lgpl3 :: License-lgpl3 = unlines-    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"-    , "                       Version 3, 29 June 2007"-    , ""-    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , ""-    , "  This version of the GNU Lesser General Public License incorporates"-    , "the terms and conditions of version 3 of the GNU General Public"-    , "License, supplemented by the additional permissions listed below."-    , ""-    , "  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"-    , "General Public License."-    , ""-    , "  \"The Library\" refers to a covered work governed by this License,"-    , "other than an Application or a Combined Work as defined below."-    , ""-    , "  An \"Application\" is any work that makes use of an interface provided"-    , "by the Library, but which is not otherwise based on the Library."-    , "Defining a subclass of a class defined by the Library is deemed a mode"-    , "of using an interface provided by the Library."-    , ""-    , "  A \"Combined Work\" is a work produced by combining or linking an"-    , "Application with the Library.  The particular version of the Library"-    , "with which the Combined Work was made is also called the \"Linked"-    , "Version\"."-    , ""-    , "  The \"Minimal Corresponding Source\" for a Combined Work means the"-    , "Corresponding Source for the Combined Work, excluding any source code"-    , "for portions of the Combined Work that, considered in isolation, are"-    , "based on the Application, and not on the Linked Version."-    , ""-    , "  The \"Corresponding Application Code\" for a Combined Work means the"-    , "object code and/or source code for the Application, including any data"-    , "and utility programs needed for reproducing the Combined Work from the"-    , "Application, but excluding the System Libraries of the Combined Work."-    , ""-    , "  1. Exception to Section 3 of the GNU GPL."-    , ""-    , "  You may convey a covered work under sections 3 and 4 of this License"-    , "without being bound by section 3 of the GNU GPL."-    , ""-    , "  2. Conveying Modified Versions."-    , ""-    , "  If you modify a copy of the Library, and, in your modifications, a"-    , "facility refers to a function or data to be supplied by an Application"-    , "that uses the facility (other than as an argument passed when the"-    , "facility is invoked), then you may convey a copy of the modified"-    , "version:"-    , ""-    , "   a) under this License, provided that you make a good faith effort to"-    , "   ensure that, in the event an Application does not supply the"-    , "   function or data, the facility still operates, and performs"-    , "   whatever part of its purpose remains meaningful, or"-    , ""-    , "   b) under the GNU GPL, with none of the additional permissions of"-    , "   this License applicable to that copy."-    , ""-    , "  3. Object Code Incorporating Material from Library Header Files."-    , ""-    , "  The object code form of an Application may incorporate material from"-    , "a header file that is part of the Library.  You may convey such object"-    , "code under terms of your choice, provided that, if the incorporated"-    , "material is not limited to numerical parameters, data structure"-    , "layouts and accessors, or small macros, inline functions and templates"-    , "(ten or fewer lines in length), you do both of the following:"-    , ""-    , "   a) Give prominent notice with each copy of the object code that the"-    , "   Library is used in it and that the Library and its use are"-    , "   covered by this License."-    , ""-    , "   b) Accompany the object code with a copy of the GNU GPL and this license"-    , "   document."-    , ""-    , "  4. Combined Works."-    , ""-    , "  You may convey a Combined Work under terms of your choice that,"-    , "taken together, effectively do not restrict modification of the"-    , "portions of the Library contained in the Combined Work and reverse"-    , "engineering for debugging such modifications, if you also do each of"-    , "the following:"-    , ""-    , "   a) Give prominent notice with each copy of the Combined Work that"-    , "   the Library is used in it and that the Library and its use are"-    , "   covered by this License."-    , ""-    , "   b) Accompany the Combined Work with a copy of the GNU GPL and this license"-    , "   document."-    , ""-    , "   c) For a Combined Work that displays copyright notices during"-    , "   execution, include the copyright notice for the Library among"-    , "   these notices, as well as a reference directing the user to the"-    , "   copies of the GNU GPL and this license document."-    , ""-    , "   d) Do one of the following:"-    , ""-    , "       0) Convey the Minimal Corresponding Source under the terms of this"-    , "       License, and the Corresponding Application Code in a form"-    , "       suitable for, and under terms that permit, the user to"-    , "       recombine or relink the Application with a modified version of"-    , "       the Linked Version to produce a modified Combined Work, in the"-    , "       manner specified by section 6 of the GNU GPL for conveying"-    , "       Corresponding Source."-    , ""-    , "       1) Use a suitable shared library mechanism for linking with the"-    , "       Library.  A suitable mechanism is one that (a) uses at run time"-    , "       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."-    , ""-    , "   e) Provide Installation Information, but only if you would otherwise"-    , "   be required to provide such information under section 6 of the"-    , "   GNU GPL, and only to the extent that such information is"-    , "   necessary to install and execute a modified version of the"-    , "   Combined Work produced by recombining or relinking the"-    , "   Application with a modified version of the Linked Version. (If"-    , "   you use option 4d0, the Installation Information must accompany"-    , "   the Minimal Corresponding Source and Corresponding Application"-    , "   Code. If you use option 4d1, you must provide the Installation"-    , "   Information in the manner specified by section 6 of the GNU GPL"-    , "   for conveying Corresponding Source.)"-    , ""-    , "  5. Combined Libraries."-    , ""-    , "  You may place library facilities that are a work based on the"-    , "Library side by side in a single library together with other library"-    , "facilities that are not Applications and are not covered by this"-    , "License, and convey such a combined library under terms of your"-    , "choice, if you do both of the following:"-    , ""-    , "   a) Accompany the combined library with a copy of the same work based"-    , "   on the Library, uncombined with any other library facilities,"-    , "   conveyed under the terms of this License."-    , ""-    , "   b) Give prominent notice with the combined library that part of it"-    , "   is a work based on the Library, and explaining where to find the"-    , "   accompanying uncombined form of the same work."-    , ""-    , "  6. Revised Versions of the GNU Lesser General Public License."-    , ""-    , "  The Free Software Foundation may publish revised and/or new versions"-    , "of the GNU 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."-    , ""-    , "  Each version is given a distinguishing version number. If the"-    , "Library as you received it specifies that a certain numbered version"-    , "of the GNU Lesser General Public License \"or any later version\""-    , "applies to it, you have the option of following the terms and"-    , "conditions either of that published version or of any later version"-    , "published by the Free Software Foundation. If the Library as you"-    , "received it does not specify a version number of the GNU Lesser"-    , "General Public License, you may choose any version of the GNU Lesser"-    , "General Public License ever published by the Free Software Foundation."-    , ""-    , "  If the Library as you received it specifies that a proxy can decide"-    , "whether future versions of the GNU Lesser General Public License shall"-    , "apply, that proxy's public statement of acceptance of any version is"-    , "permanent authorization for you to choose that version for the"-    , "Library."-    ]--apache20 :: License-apache20 = unlines-    [ ""-    , "                                 Apache License"-    , "                           Version 2.0, January 2004"-    , "                        http://www.apache.org/licenses/"-    , ""-    , "   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION"-    , ""-    , "   1. Definitions."-    , ""-    , "      \"License\" shall mean the terms and conditions for use, reproduction,"-    , "      and distribution as defined by Sections 1 through 9 of this document."-    , ""-    , "      \"Licensor\" shall mean the copyright owner or entity authorized by"-    , "      the copyright owner that is granting the License."-    , ""-    , "      \"Legal Entity\" shall mean the union of the acting entity and all"-    , "      other entities that control, are controlled by, or are under common"-    , "      control with that entity. For the purposes of this definition,"-    , "      \"control\" means (i) the power, direct or indirect, to cause the"-    , "      direction or management of such entity, whether by contract or"-    , "      otherwise, or (ii) ownership of fifty percent (50%) or more of the"-    , "      outstanding shares, or (iii) beneficial ownership of such entity."-    , ""-    , "      \"You\" (or \"Your\") shall mean an individual or Legal Entity"-    , "      exercising permissions granted by this License."-    , ""-    , "      \"Source\" form shall mean the preferred form for making modifications,"-    , "      including but not limited to software source code, documentation"-    , "      source, and configuration files."-    , ""-    , "      \"Object\" form shall mean any form resulting from mechanical"-    , "      transformation or translation of a Source form, including but"-    , "      not limited to compiled object code, generated documentation,"-    , "      and conversions to other media types."-    , ""-    , "      \"Work\" shall mean the work of authorship, whether in Source or"-    , "      Object form, made available under the License, as indicated by a"-    , "      copyright notice that is included in or attached to the work"-    , "      (an example is provided in the Appendix below)."-    , ""-    , "      \"Derivative Works\" shall mean any work, whether in Source or Object"-    , "      form, that is based on (or derived from) the Work and for which the"-    , "      editorial revisions, annotations, elaborations, or other modifications"-    , "      represent, as a whole, an original work of authorship. For the purposes"-    , "      of this License, Derivative Works shall not include works that remain"-    , "      separable from, or merely link (or bind by name) to the interfaces of,"-    , "      the Work and Derivative Works thereof."-    , ""-    , "      \"Contribution\" shall mean any work of authorship, including"-    , "      the original version of the Work and any modifications or additions"-    , "      to that Work or Derivative Works thereof, that is intentionally"-    , "      submitted to Licensor for inclusion in the Work by the copyright owner"-    , "      or by an individual or Legal Entity authorized to submit on behalf of"-    , "      the copyright owner. For the purposes of this definition, \"submitted\""-    , "      means any form of electronic, verbal, or written communication sent"-    , "      to the Licensor or its representatives, including but not limited to"-    , "      communication on electronic mailing lists, source code control systems,"-    , "      and issue tracking systems that are managed by, or on behalf of, the"-    , "      Licensor for the purpose of discussing and improving the Work, but"-    , "      excluding communication that is conspicuously marked or otherwise"-    , "      designated in writing by the copyright owner as \"Not a Contribution.\""-    , ""-    , "      \"Contributor\" shall mean Licensor and any individual or Legal Entity"-    , "      on behalf of whom a Contribution has been received by Licensor and"-    , "      subsequently incorporated within the Work."-    , ""-    , "   2. Grant of Copyright License. Subject to the terms and conditions of"-    , "      this License, each Contributor hereby grants to You a perpetual,"-    , "      worldwide, non-exclusive, no-charge, royalty-free, irrevocable"-    , "      copyright license to reproduce, prepare Derivative Works of,"-    , "      publicly display, publicly perform, sublicense, and distribute the"-    , "      Work and such Derivative Works in Source or Object form."-    , ""-    , "   3. Grant of Patent License. Subject to the terms and conditions of"-    , "      this License, each Contributor hereby grants to You a perpetual,"-    , "      worldwide, non-exclusive, no-charge, royalty-free, irrevocable"-    , "      (except as stated in this section) patent license to make, have made,"-    , "      use, offer to sell, sell, import, and otherwise transfer the Work,"-    , "      where such license applies only to those patent claims licensable"-    , "      by such Contributor that are necessarily infringed by their"-    , "      Contribution(s) alone or by combination of their Contribution(s)"-    , "      with the Work to which such Contribution(s) was submitted. If You"-    , "      institute patent litigation against any entity (including a"-    , "      cross-claim or counterclaim in a lawsuit) alleging that the Work"-    , "      or a Contribution incorporated within the Work constitutes direct"-    , "      or contributory patent infringement, then any patent licenses"-    , "      granted to You under this License for that Work shall terminate"-    , "      as of the date such litigation is filed."-    , ""-    , "   4. Redistribution. You may reproduce and distribute copies of the"-    , "      Work or Derivative Works thereof in any medium, with or without"-    , "      modifications, and in Source or Object form, provided that You"-    , "      meet the following conditions:"-    , ""-    , "      (a) You must give any other recipients of the Work or"-    , "          Derivative Works a copy of this License; and"-    , ""-    , "      (b) You must cause any modified files to carry prominent notices"-    , "          stating that You changed the files; and"-    , ""-    , "      (c) You must retain, in the Source form of any Derivative Works"-    , "          that You distribute, all copyright, patent, trademark, and"-    , "          attribution notices from the Source form of the Work,"-    , "          excluding those notices that do not pertain to any part of"-    , "          the Derivative Works; and"-    , ""-    , "      (d) If the Work includes a \"NOTICE\" text file as part of its"-    , "          distribution, then any Derivative Works that You distribute must"-    , "          include a readable copy of the attribution notices contained"-    , "          within such NOTICE file, excluding those notices that do not"-    , "          pertain to any part of the Derivative Works, in at least one"-    , "          of the following places: within a NOTICE text file distributed"-    , "          as part of the Derivative Works; within the Source form or"-    , "          documentation, if provided along with the Derivative Works; or,"-    , "          within a display generated by the Derivative Works, if and"-    , "          wherever such third-party notices normally appear. The contents"-    , "          of the NOTICE file are for informational purposes only and"-    , "          do not modify the License. You may add Your own attribution"-    , "          notices within Derivative Works that You distribute, alongside"-    , "          or as an addendum to the NOTICE text from the Work, provided"-    , "          that such additional attribution notices cannot be construed"-    , "          as modifying the License."-    , ""-    , "      You may add Your own copyright statement to Your modifications and"-    , "      may provide additional or different license terms and conditions"-    , "      for use, reproduction, or distribution of Your modifications, or"-    , "      for any such Derivative Works as a whole, provided Your use,"-    , "      reproduction, and distribution of the Work otherwise complies with"-    , "      the conditions stated in this License."-    , ""-    , "   5. Submission of Contributions. Unless You explicitly state otherwise,"-    , "      any Contribution intentionally submitted for inclusion in the Work"-    , "      by You to the Licensor shall be under the terms and conditions of"-    , "      this License, without any additional terms or conditions."-    , "      Notwithstanding the above, nothing herein shall supersede or modify"-    , "      the terms of any separate license agreement you may have executed"-    , "      with Licensor regarding such Contributions."-    , ""-    , "   6. Trademarks. This License does not grant permission to use the trade"-    , "      names, trademarks, service marks, or product names of the Licensor,"-    , "      except as required for reasonable and customary use in describing the"-    , "      origin of the Work and reproducing the content of the NOTICE file."-    , ""-    , "   7. Disclaimer of Warranty. Unless required by applicable law or"-    , "      agreed to in writing, Licensor provides the Work (and each"-    , "      Contributor provides its Contributions) on an \"AS IS\" BASIS,"-    , "      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or"-    , "      implied, including, without limitation, any warranties or conditions"-    , "      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A"-    , "      PARTICULAR PURPOSE. You are solely responsible for determining the"-    , "      appropriateness of using or redistributing the Work and assume any"-    , "      risks associated with Your exercise of permissions under this License."-    , ""-    , "   8. Limitation of Liability. In no event and under no legal theory,"-    , "      whether in tort (including negligence), contract, or otherwise,"-    , "      unless required by applicable law (such as deliberate and grossly"-    , "      negligent acts) or agreed to in writing, shall any Contributor be"-    , "      liable to You for damages, including any direct, indirect, special,"-    , "      incidental, or consequential damages of any character arising as a"-    , "      result of this License or out of the use or inability to use the"-    , "      Work (including but not limited to damages for loss of goodwill,"-    , "      work stoppage, computer failure or malfunction, or any and all"-    , "      other commercial damages or losses), even if such Contributor"-    , "      has been advised of the possibility of such damages."-    , ""-    , "   9. Accepting Warranty or Additional Liability. While redistributing"-    , "      the Work or Derivative Works thereof, You may choose to offer,"-    , "      and charge a fee for, acceptance of support, warranty, indemnity,"-    , "      or other liability obligations and/or rights consistent with this"-    , "      License. However, in accepting such obligations, You may act only"-    , "      on Your own behalf and on Your sole responsibility, not on behalf"-    , "      of any other Contributor, and only if You agree to indemnify,"-    , "      defend, and hold each Contributor harmless for any liability"-    , "      incurred by, or claims asserted against, such Contributor by reason"-    , "      of your accepting any such warranty or additional liability."-    , ""-    , "   END OF TERMS AND CONDITIONS"-    , ""-    , "   APPENDIX: How to apply the Apache License to your work."-    , ""-    , "      To apply the Apache License to your work, attach the following"-    , "      boilerplate notice, with the fields enclosed by brackets \"[]\""-    , "      replaced with your own identifying information. (Don't include"-    , "      the brackets!)  The text should be enclosed in the appropriate"-    , "      comment syntax for the file format. We also recommend that a"-    , "      file or class name and description of purpose be included on the"-    , "      same \"printed page\" as the copyright notice for easier"-    , "      identification within third-party archives."-    , ""-    , "   Copyright [yyyy] [name of copyright owner]"-    , ""-    , "   Licensed under the Apache License, Version 2.0 (the \"License\");"-    , "   you may not use this file except in compliance with the License."-    , "   You may obtain a copy of the License at"-    , ""-    , "       http://www.apache.org/licenses/LICENSE-2.0"-    , ""-    , "   Unless required by applicable law or agreed to in writing, software"-    , "   distributed under the License is distributed on an \"AS IS\" BASIS,"-    , "   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."-    ]--isc :: String -> String -> License-isc authors year = unlines-    [ "Copyright (c) " ++ year ++ " " ++ authors-    , ""-    , "Permission to use, copy, modify, and/or distribute this software for any purpose"-    , "with or without fee is hereby granted, provided that the above copyright notice"-    , "and this permission notice appear in all copies."-    , ""-    , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH"-    , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND"-    , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,"-    , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS"-    , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER"-    , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF"-    , "THIS SOFTWARE."-    ]
− Distribution/Client/Init/Prompt.hs 
@@ -1,145 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Prompt--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ User prompt utility functions for use by the 'cabal init' command.-----------------------------------------------------------------------------------module Distribution.Client.Init.Prompt (--    -- * Commands-    prompt-  , promptYesNo-  , promptStr-  , promptList-  , promptListOptional-  , maybePrompt-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (empty)--import Distribution.Client.Init.Types-  ( InitFlags(..) )-import Distribution.Simple.Setup-  ( Flag(..) )----- | Run a prompt or not based on the interactive flag of the---   InitFlags structure.-maybePrompt :: InitFlags -> IO t -> IO (Maybe t)-maybePrompt flags p =-  case interactive flags of-    Flag True -> Just `fmap` p-    _         -> return Nothing---- | Create a prompt with optional default value that returns a---   String.-promptStr :: String -> Maybe String -> IO String-promptStr = promptDefault' Just id---- | Create a yes/no prompt with optional default value.-promptYesNo :: String      -- ^ prompt message-            -> Maybe Bool  -- ^ optional default value-            -> IO Bool-promptYesNo =-    promptDefault' recogniseYesNo showYesNo-  where-    recogniseYesNo s | s == "y" || s == "Y" = Just True-                     | s == "n" || s == "N" = Just False-                     | otherwise            = Nothing-    showYesNo True  = "y"-    showYesNo False = "n"---- | Create a prompt with optional default value that returns a value---   of some Text instance.-prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t-prompt = promptDefault' simpleParsec prettyShow---- | Create a prompt with an optional default value.-promptDefault' :: (String -> Maybe t)       -- ^ parser-               -> (t -> String)             -- ^ pretty-printer-               -> String                    -- ^ prompt message-               -> Maybe t                   -- ^ optional default value-               -> IO t-promptDefault' parser ppr pr def = do-  putStr $ mkDefPrompt pr (ppr `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d)  -> return d-    _  -> case parser inp of-            Just t  -> return t-            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"-                          promptDefault' parser ppr pr def---- | Create a prompt from a prompt string and a String representation---   of an optional default value.-mkDefPrompt :: String -> Maybe String -> String-mkDefPrompt pr def = pr ++ "?" ++ defStr def-  where defStr Nothing  = " "-        defStr (Just s) = " [default: " ++ s ++ "] "---- | Create a prompt from a list of items, where no selected items is---   valid and will be represented as a return value of 'Nothing'.-promptListOptional :: (Pretty t, Eq t)-                   => String            -- ^ prompt-                   -> [t]               -- ^ choices-                   -> IO (Maybe (Either String t))-promptListOptional pr choices = promptListOptional' pr choices prettyShow--promptListOptional' :: Eq t-                   => String            -- ^ prompt-                   -> [t]               -- ^ choices-                   -> (t -> String)     -- ^ show an item-                   -> IO (Maybe (Either String t))-promptListOptional' pr choices displayItem =-    fmap rearrange-  $ promptList pr (Nothing : map Just choices) (Just Nothing)-               (maybe "(none)" displayItem) True-  where-    rearrange = either (Just . Left) (fmap Right)---- | Create a prompt from a list of items.-promptList :: Eq t-           => String            -- ^ prompt-           -> [t]               -- ^ choices-           -> Maybe t           -- ^ optional default value-           -> (t -> String)     -- ^ show an item-           -> Bool              -- ^ whether to allow an 'other' option-           -> IO (Either String t)-promptList pr choices def displayItem other = do-  putStrLn $ pr ++ ":"-  let options1 = map (\c -> (Just c == def, displayItem c)) choices-      options2 = zip ([1..]::[Int])-                     (options1 ++ [(False, "Other (specify)") | other])-  traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2-  promptList' displayItem (length options2) choices def other- where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest-                      | otherwise = " " ++ star i ++ rest-                  where rest = show n ++ ") "-                        star True = "*"-                        star False = " "--promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)-promptList' displayItem numChoices choices def other = do-  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d) -> return $ Right d-    _  -> case readMaybe inp of-            Nothing -> invalidChoice inp-            Just n  -> getChoice n- where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."-                              promptList' displayItem numChoices choices def other-       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)-                   | n < numChoices ||-                     (n == numChoices && not other)-                                  = return . Right $ choices !! (n-1)-                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing
− Distribution/Client/Init/Types.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Types--- Copyright   :  (c) Brent Yorgey, Benedikt Huber 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Some types used by the 'cabal init' command.----------------------------------------------------------------------------------module Distribution.Client.Init.Types where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Simple.Setup (Flag(..), toFlag )--import Distribution.Types.Dependency as P-import Distribution.Version-import Distribution.Verbosity-import qualified Distribution.Package as P-import Distribution.SPDX.License (License)-import Distribution.ModuleName-import Distribution.CabalSpecVersion-import Language.Haskell.Extension ( Language(..), Extension )--import qualified Text.PrettyPrint as Disp-import qualified Distribution.Compat.CharParsing as P-import qualified Data.Map as Map---- | InitFlags is really just a simple type to represent certain---   portions of a .cabal file.  Rather than have a flag for EVERY---   possible field, we just have one for each field that the user is---   likely to want and/or that we are likely to be able to---   intelligently guess.-data InitFlags =-    InitFlags { interactive    :: Flag Bool-              , quiet          :: Flag Bool-              , packageDir     :: Flag FilePath-              , noComments     :: Flag Bool-              , minimal        :: Flag Bool-              , simpleProject  :: Flag Bool--              , packageName  :: Flag P.PackageName-              , version      :: Flag Version-              , cabalVersion :: Flag CabalSpecVersion-              , license      :: Flag License-              , author       :: Flag String-              , email        :: Flag String-              , homepage     :: Flag String--              , synopsis     :: Flag String-              , category     :: Flag (Either String Category)-              , extraSrc     :: Maybe [String]--              , packageType  :: Flag PackageType-              , mainIs       :: Flag FilePath-              , language     :: Flag Language--              , exposedModules :: Maybe [ModuleName]-              , otherModules   :: Maybe [ModuleName]-              , otherExts      :: Maybe [Extension]--              , dependencies    :: Maybe [P.Dependency]-              , applicationDirs :: Maybe [String]-              , sourceDirs      :: Maybe [String]-              , buildTools      :: Maybe [String]--              , initializeTestSuite :: Flag Bool-              , testDirs            :: Maybe [String]--              , initHcPath    :: Flag FilePath--              , initVerbosity :: Flag Verbosity-              , overwrite     :: Flag Bool-              }-  deriving (Show, Generic)--  -- the Monoid instance for Flag has later values override earlier-  -- ones, which is why we want Maybe [foo] for collecting foo values,-  -- not Flag [foo].--data BuildType = LibBuild | ExecBuild-  deriving Eq---- The type of package to initialize.-data PackageType = Library | Executable | LibraryAndExecutable-  deriving (Show, Read, Eq)--displayPackageType :: PackageType -> String-displayPackageType LibraryAndExecutable = "Library and Executable"-displayPackageType pkgtype              = show pkgtype--instance Monoid InitFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup InitFlags where-  (<>) = gmappend--defaultInitFlags :: InitFlags-defaultInitFlags  = mempty-    { initVerbosity = toFlag normal-    }---- | Some common package categories (non-exhaustive list).-data Category-    = Codec-    | Concurrency-    | Control-    | Data-    | Database-    | Development-    | Distribution-    | Game-    | Graphics-    | Language-    | Math-    | Network-    | Sound-    | System-    | Testing-    | Text-    | Web-    deriving (Read, Show, Eq, Ord, Bounded, Enum)--instance Pretty Category where-  pretty = Disp.text . show--instance Parsec Category where-  parsec = do-    name <- P.munch1 isAlpha-    case Map.lookup name names of-      Just cat -> pure cat-      _        -> P.unexpected $ "Category: " ++ name-    where-      names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ]
− Distribution/Client/Init/Utils.hs 
@@ -1,38 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Utils--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Shared utilities used by multiple cabal init modules.-----------------------------------------------------------------------------------module Distribution.Client.Init.Utils (-    eligibleForTestSuite-  , message-  ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Simple.Setup-  ( Flag(..) )-import Distribution.Client.Init.Types-  ( InitFlags(..), PackageType(..) )---- | Returns true if this package is eligible for test suite initialization.-eligibleForTestSuite :: InitFlags -> Bool-eligibleForTestSuite flags =-  Flag True == initializeTestSuite flags-  && Flag Executable /= packageType flags---- | Possibly generate a message to stdout, taking into account the---   --quiet flag.-message :: InitFlags -> String -> IO ()-message (InitFlags{quiet = Flag True}) _ = return ()-message _ s = putStrLn s
− Distribution/Client/Install.hs 
@@ -1,1587 +0,0 @@-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Install--- Copyright   :  (c) 2005 David Himmelstrup---                    2007 Bjorn Bringert---                    2007-2010 Duncan Coutts--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ High level interface to package installation.-------------------------------------------------------------------------------module Distribution.Client.Install (-    -- * High-level interface-    install,--    -- * Lower-level interface that allows to manipulate the install plan-    makeInstallContext,-    makeInstallPlan,-    processInstallPlan,-    InstallArgs,-    InstallContext,--    -- * Prune certain packages from the install plan-    pruneInstallPlan-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Distribution.Utils.Generic(safeLast)--import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map-import Control.Exception as Exception-         ( bracket, catches, Handler(Handler), handleJust )-import System.Directory-         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,-           createDirectoryIfMissing, removeFile, renameDirectory,-           getDirectoryContents )-import System.FilePath-         ( (</>), (<.>), equalFilePath, takeDirectory )-import System.IO-         ( openFile, IOMode(AppendMode), hClose )-import System.IO.Error-         ( isDoesNotExistError, ioeGetFileName )--import Distribution.Client.Targets-import Distribution.Client.Configure-         ( chooseCabalVersion, configureSetupScript, checkConfigExFlags )-import Distribution.Client.Dependency-import Distribution.Client.Dependency.Types-         ( Solver(..) )-import Distribution.Client.FetchUtils-import Distribution.Client.HttpUtils-         ( HttpTransport (..) )-import Distribution.Solver.Types.PackageFixedDeps-import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)-import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackagesAtIndexState, getInstalledPackages )-import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)-import Distribution.Client.Setup-         ( GlobalFlags(..), RepoContext(..)-         , ConfigFlags(..), configureCommand, filterConfigureFlags-         , ConfigExFlags(..), InstallFlags(..)-         , filterTestFlags )-import Distribution.Client.Config-         ( getCabalDir, defaultUserInstall )-import Distribution.Client.Tar (extractTarGzFile)-import Distribution.Client.Types as Source-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.BuildReports.Anonymous (showBuildReport)-import qualified Distribution.Client.BuildReports.Anonymous as BuildReports-import qualified Distribution.Client.BuildReports.Storage as BuildReports-         ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )-import qualified Distribution.Client.InstallSymlink as InstallSymlink-         ( symlinkBinaries )-import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))-import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade-import qualified Distribution.Client.World as World-import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.Client.JobControl--import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.ConstraintSource-import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.LabeledPackageConstraint-import           Distribution.Solver.Types.OptionalStanza-import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex-import           Distribution.Solver.Types.PkgConfigDb-                   ( PkgConfigDb, readPkgConfigDb )-import           Distribution.Solver.Types.SourcePackage as SourcePackage--import Distribution.Utils.NubList-import Distribution.Simple.Compiler-         ( CompilerId(..), Compiler(compilerId), compilerFlavor-         , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramDb)-import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.Simple.Setup-         ( haddockCommand, HaddockFlags(..)-         , buildCommand, BuildFlags(..), emptyBuildFlags-         , TestFlags, BenchmarkFlags-         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )-import qualified Distribution.Simple.Setup as Cabal-         ( Flag(..)-         , copyCommand, CopyFlags(..), emptyCopyFlags-         , registerCommand, RegisterFlags(..), emptyRegisterFlags-         , testCommand, TestFlags(..) )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, writeFileAtomic )-import Distribution.Simple.InstallDirs as InstallDirs-         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate-         , initialPathTemplateEnv, installDirsTemplateEnv )-import Distribution.Simple.Configure (interpretPackageDbFlags)-import Distribution.Simple.Register (registerPackage, defaultRegisterOptions)-import Distribution.Package-         ( PackageIdentifier(..), PackageId, packageName, packageVersion-         , Package(..), HasMungedPackageId(..), HasUnitId(..)-         , UnitId )-import Distribution.Types.Dependency-         ( Dependency (..), mainLibSet )-import Distribution.Types.GivenComponent-         ( GivenComponent(..) )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint(..), thisPackageVersionConstraint )-import Distribution.Types.MungedPackageId-import qualified Distribution.PackageDescription as PackageDescription-import Distribution.PackageDescription-         ( PackageDescription, GenericPackageDescription(..) )-import Distribution.Types.Flag-         ( PackageFlag(..), FlagAssignment, mkFlagAssignment-         , showFlagAssignment, diffFlagAssignment, nullFlagAssignment )-import Distribution.PackageDescription.Configuration-         ( finalizePD )-import Distribution.Version-         ( Version, VersionRange, foldVersionRange )-import Distribution.Simple.Utils as Utils-         ( notice, info, warn, debug, debugNoWrap, die'-         , withTempDirectory )-import Distribution.Client.Utils-         ( determineNumJobs, logDirChange, mergeBy, MergeResult(..)-         , ProgressPhase(..), progressMessage )-import Distribution.System-         ( Platform, OS(Windows), buildOS, buildPlatform )-import Distribution.Verbosity as Verbosity-         ( modifyVerbosity, normal, verbose )-import Distribution.Simple.BuildPaths ( exeExtension )--import qualified Data.ByteString as BS----TODO:--- * assign flags to packages individually---   * complain about flags that do not apply to any package given as target---     so flags do not apply to dependencies, only listed, can use flag---     constraints for dependencies---   * only record applicable flags in world file--- * allow flag constraints--- * allow installed constraints--- * allow flag and installed preferences--- * change world file to use cabal section syntax---   * allow persistent configure flags for each package individually---- --------------------------------------------------------------- * Top level user actions--- ---------------------------------------------------------------- | Installs the packages needed to satisfy a list of dependencies.----install-  :: Verbosity-  -> PackageDBStack-  -> RepoContext-  -> Compiler-  -> Platform-  -> ProgramDb-  -> GlobalFlags-  -> ConfigFlags-  -> ConfigExFlags-  -> InstallFlags-  -> HaddockFlags-  -> TestFlags-  -> BenchmarkFlags-  -> [UserTarget]-  -> IO ()-install verbosity packageDBs repos comp platform progdb-  globalFlags configFlags configExFlags installFlags-  haddockFlags testFlags benchmarkFlags userTargets0 = do--    unless (installRootCmd installFlags == Cabal.NoFlag) $-        warn verbosity $ "--root-cmd is no longer supported, "-        ++ "see https://github.com/haskell/cabal/issues/3353"-        ++ " (if you didn't type --root-cmd, comment out root-cmd"-        ++ " in your ~/.cabal/config file)"-    let userOrSandbox = fromFlag (configUserInstall configFlags)-    unless userOrSandbox $-        warn verbosity $ "the --global flag is deprecated -- "-        ++ "it is generally considered a bad idea to install packages "-        ++ "into the global store"--    installContext <- makeInstallContext verbosity args (Just userTargets0)-    planResult     <- foldProgress logMsg (return . Left) (return . Right) =<<-                      makeInstallPlan verbosity args installContext--    case planResult of-        Left message -> do-            reportPlanningFailure verbosity args installContext message-            die'' message-        Right installPlan ->-            processInstallPlan verbosity args installContext installPlan-  where-    args :: InstallArgs-    args = (packageDBs, repos, comp, platform, progdb,-            globalFlags, configFlags, configExFlags,-            installFlags, haddockFlags, testFlags, benchmarkFlags)--    die'' = die' verbosity--    logMsg message rest = debugNoWrap verbosity message >> rest---- TODO: Make InstallContext a proper data type with documented fields.--- | Common context for makeInstallPlan and processInstallPlan.-type InstallContext = ( InstalledPackageIndex, SourcePackageDb-                      , PkgConfigDb-                      , [UserTarget], [PackageSpecifier UnresolvedSourcePackage]-                      , HttpTransport )---- 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-                   , RepoContext-                   , Compiler-                   , Platform-                   , ProgramDb-                   , GlobalFlags-                   , ConfigFlags-                   , ConfigExFlags-                   , InstallFlags-                   , HaddockFlags-                   , TestFlags-                   , BenchmarkFlags )---- | Make an install context given install arguments.-makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]-                      -> IO InstallContext-makeInstallContext verbosity-  (packageDBs, repoCtxt, comp, _, progdb,-   globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do--    let idxState = flagToMaybe (installIndexState installFlags)--    installedPkgIndex   <- getInstalledPackages verbosity comp packageDBs progdb-    (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing-    pkgConfigDb         <- readPkgConfigDb      verbosity progdb--    checkConfigExFlags verbosity installedPkgIndex-                       (packageIndex sourcePkgDb) configExFlags-    transport <- repoContextGetTransport repoCtxt--    (userTargets, pkgSpecifiers) <- case mUserTargets of-      Nothing           ->-        -- We want to distinguish between the case where the user has given an-        -- empty list of targets on the command-line and the case where we-        -- specifically want to have an empty list of targets.-        return ([], [])-      Just userTargets0 -> do-        -- For install, if no target is given it means we use the current-        -- directory as the single target.-        let userTargets | null userTargets0 = [UserTargetLocalDir "."]-                        | otherwise         = userTargets0--        pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                         (fromFlag $ globalWorldFile globalFlags)-                         (packageIndex sourcePkgDb)-                         userTargets-        return (userTargets, pkgSpecifiers)--    return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets-           ,pkgSpecifiers, transport)---- | Make an install plan given install context and install arguments.-makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext-                -> IO (Progress String String SolverInstallPlan)-makeInstallPlan verbosity-  (_, _, comp, platform,_,-   _, configFlags, configExFlags, installFlags,-   _, _, _)-  (installedPkgIndex, sourcePkgDb, pkgConfigDb,-   _, pkgSpecifiers, _) = do--    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))-              (compilerInfo comp)-    notice verbosity "Resolving dependencies..."-    return $ planPackages verbosity comp platform solver-          configFlags configExFlags installFlags-          installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers---- | Given an install plan, perform the actual installations.-processInstallPlan :: Verbosity -> InstallArgs -> InstallContext-                   -> SolverInstallPlan-                   -> IO ()-processInstallPlan verbosity-  args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _)-  (installedPkgIndex, sourcePkgDb, _,-   userTargets, pkgSpecifiers, _) installPlan0 = do--    checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb-      installFlags pkgSpecifiers--    unless (dryRun || nothingToInstall) $ do-      buildOutcomes <- performInstallations verbosity-                       args installedPkgIndex installPlan-      postInstallActions verbosity args userTargets installPlan buildOutcomes-  where-    installPlan = InstallPlan.configureInstallPlan configFlags installPlan0-    dryRun = fromFlag (installDryRun installFlags)-    nothingToInstall = null (fst (InstallPlan.ready installPlan))---- --------------------------------------------------------------- * Installation planning--- --------------------------------------------------------------planPackages :: Verbosity-             -> Compiler-             -> Platform-             -> Solver-             -> ConfigFlags-             -> ConfigExFlags-             -> InstallFlags-             -> InstalledPackageIndex-             -> SourcePackageDb-             -> PkgConfigDb-             -> [PackageSpecifier UnresolvedSourcePackage]-             -> Progress String String SolverInstallPlan-planPackages verbosity comp platform solver-             configFlags configExFlags installFlags-             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =--        resolveDependencies-          platform (compilerInfo comp) pkgConfigDb-          solver-          resolverParams--    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return--  where-    resolverParams =--        setMaxBackjumps (if maxBackjumps < 0 then Nothing-                                             else Just maxBackjumps)--      . setIndependentGoals independentGoals--      . setReorderGoals reorderGoals--      . setCountConflicts countConflicts--      . setFineGrainedConflicts fineGrainedConflicts--      . setMinimizeConflictSet minimizeConflictSet--      . setAvoidReinstalls avoidReinstalls--      . setShadowPkgs shadowPkgs--      . setStrongFlags strongFlags--      . setAllowBootLibInstalls allowBootLibInstalls--      . setOnlyConstrained onlyConstrained--      . setSolverVerbosity verbosity--      . setPreferenceDefault (if upgradeDeps then PreferAllLatest-                                             else PreferLatestForSelected)--      . removeLowerBounds allowOlder-      . removeUpperBounds allowNewer--      . addPreferences-          -- preferences from the config file or command line-          [ PackageVersionPreference name ver-          | PackageVersionConstraint name ver <- configPreferences configExFlags ]--      . addConstraints-          -- version constraints from the config file or command line-            [ LabeledPackageConstraint (userToPackageConstraint pc) src-            | (pc, src) <- configExConstraints configExFlags ]--      . addConstraints-          --FIXME: this just applies all flags to all targets which-          -- is silly. We should check if the flags are appropriate-          [ let pc = PackageConstraint-                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)-                     (PackagePropertyFlags flags)-            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget-          | let flags = configConfigurationsFlags configFlags-          , not (nullFlagAssignment flags)-          , pkgSpecifier <- pkgSpecifiers ]--      . addConstraints-          [ let pc = PackageConstraint-                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)-                     (PackagePropertyStanzas stanzas)-            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget-          | pkgSpecifier <- pkgSpecifiers ]--      . (if reinstall then reinstallTargets else id)--        -- Don't solve for executables, the legacy install codepath-        -- doesn't understand how to install them-      . setSolveExecutables (SolveExecutables False)--      $ standardInstallPolicy-        installedPkgIndex sourcePkgDb pkgSpecifiers--    stanzas           = [ TestStanzas | testsEnabled ]-                     ++ [ BenchStanzas | benchmarksEnabled ]-    testsEnabled      = fromFlagOrDefault False $ configTests configFlags-    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags--    reinstall        = fromFlag (installOverrideReinstall installFlags) ||-                       fromFlag (installReinstall         installFlags)-    reorderGoals     = fromFlag (installReorderGoals      installFlags)-    countConflicts   = fromFlag (installCountConflicts    installFlags)-    fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags)-    minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags)-    independentGoals = fromFlag (installIndependentGoals  installFlags)-    avoidReinstalls  = fromFlag (installAvoidReinstalls   installFlags)-    shadowPkgs       = fromFlag (installShadowPkgs        installFlags)-    strongFlags      = fromFlag (installStrongFlags       installFlags)-    maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)-    allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)-    onlyConstrained  = fromFlag (installOnlyConstrained   installFlags)-    upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)-    onlyDeps         = fromFlag (installOnlyDeps          installFlags)--    allowOlder       = fromMaybe (AllowOlder mempty)-                                 (configAllowOlder configExFlags)-    allowNewer       = fromMaybe (AllowNewer mempty)-                                 (configAllowNewer configExFlags)---- | Remove the provided targets from the install plan.-pruneInstallPlan :: Package targetpkg-                 => [PackageSpecifier targetpkg]-                 -> SolverInstallPlan-                 -> Progress String String SolverInstallPlan-pruneInstallPlan pkgSpecifiers =-  -- TODO: this is a general feature and should be moved to D.C.Dependency-  -- Also, the InstallPlan.remove should return info more precise to the-  -- problem, rather than the very general PlanProblem type.-  either (Fail . explain) Done-  . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)-  where-    explain :: [SolverInstallPlan.SolverPlanProblem] -> String-    explain problems =-      "Cannot select only the dependencies (as requested by the "-      ++ "'--only-dependencies' flag), "-      ++ (case pkgids of-             [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "-             _       -> "the packages "-                        ++ intercalate ", " (map prettyShow pkgids) ++ " are ")-      ++ "required by a dependency of one of the other targets."-      where-        pkgids =-          nub [ depid-              | SolverInstallPlan.PackageMissingDeps _ depids <- problems-              , depid <- depids-              , packageName depid `elem` targetnames ]--    targetnames  = map pkgSpecifierTarget pkgSpecifiers---- --------------------------------------------------------------- * Informational messages--- ---------------------------------------------------------------- | Perform post-solver checks of the install plan and print it if--- either requested or needed.-checkPrintPlan :: Verbosity-               -> InstalledPackageIndex-               -> InstallPlan-               -> SourcePackageDb-               -> InstallFlags-               -> [PackageSpecifier UnresolvedSourcePackage]-               -> IO ()-checkPrintPlan verbosity installed installPlan sourcePkgDb-  installFlags pkgSpecifiers = do--  -- User targets that are already installed.-  let preExistingTargets =-        [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,-              InstallPlan.PreExisting p <- InstallPlan.toList installPlan,-              packageName p `elem` tgts ]--  -- If there's nothing to install, we print the already existing-  -- target packages as an explanation.-  when nothingToInstall $-    notice verbosity $ unlines $-         "All the requested packages are already installed:"-       : map (prettyShow . packageId) preExistingTargets-      ++ ["Use --reinstall if you want to reinstall anyway."]--  let lPlan =-        [ (pkg, status)-        | pkg <- InstallPlan.executionOrder installPlan-        , let status = packageStatus installed pkg ]-  -- Are any packages classified as reinstalls?-  let reinstalledPkgs =-        [ ipkg-        | (_pkg, status) <- lPlan-        , ipkg <- extractReinstalls status ]-  -- Packages that are already broken.-  let oldBrokenPkgs =-          map Installed.installedUnitId-        . PackageIndex.reverseDependencyClosure installed-        . map (Installed.installedUnitId . fst)-        . PackageIndex.brokenPackages-        $ installed-  let excluded = reinstalledPkgs ++ oldBrokenPkgs-  -- Packages that are reverse dependencies of replaced packages are very-  -- likely to be broken. We exclude packages that are already broken.-  let newBrokenPkgs =-        filter (\ p -> not (Installed.installedUnitId p `elem` excluded))-               (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)-  let containsReinstalls = not (null reinstalledPkgs)-  let breaksPkgs         = not (null newBrokenPkgs)--  let adaptedVerbosity-        | containsReinstalls-        , not overrideReinstall  = modifyVerbosity (max verbose) verbosity-        | otherwise              = verbosity--  -- We print the install plan if we are in a dry-run or if we are confronted-  -- with a dangerous install plan.-  when (dryRun || containsReinstalls && not overrideReinstall) $-    printPlan (dryRun || breaksPkgs && not overrideReinstall)-      adaptedVerbosity lPlan sourcePkgDb--  -- If the install plan is dangerous, we print various warning messages. In-  -- particular, if we can see that packages are likely to be broken, we even-  -- bail out (unless installation has been forced with --force-reinstalls).-  when containsReinstalls $ do-    if breaksPkgs-      then do-        (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $-            "The following packages are likely to be broken by the reinstalls:"-          : map (prettyShow . mungedId) newBrokenPkgs-          ++ if overrideReinstall-               then if dryRun then [] else-                 ["Continuing even though " ++-                  "the plan contains dangerous reinstalls."]-               else-                 ["Use --force-reinstalls if you want to install anyway."]-      else unless dryRun $ warn verbosity-             "Note that reinstalls are always dangerous. Continuing anyway..."--  -- If we are explicitly told to not download anything, check that all packages-  -- are already fetched.-  let offline = fromFlagOrDefault False (installOfflineMode installFlags)-  when offline $ do-    let pkgs = [ confPkgSource cpkg-               | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ]-    notFetched <- fmap (map packageId)-                  . filterM (fmap isNothing . checkFetched . srcpkgSource)-                  $ pkgs-    unless (null notFetched) $-      die' verbosity $ "Can't download packages in offline mode. "-      ++ "Must download the following packages to proceed:\n"-      ++ intercalate ", " (map prettyShow notFetched)-      ++ "\nTry using 'cabal fetch'."--  where-    nothingToInstall = null (fst (InstallPlan.ready installPlan))--    dryRun            = fromFlag (installDryRun            installFlags)-    overrideReinstall = fromFlag (installOverrideReinstall installFlags)--data PackageStatus = NewPackage-                   | NewVersion [Version]-                   | Reinstall  [UnitId] [PackageChange]--type PackageChange = MergeResult MungedPackageId MungedPackageId--extractReinstalls :: PackageStatus -> [UnitId]-extractReinstalls (Reinstall ipids _) = ipids-extractReinstalls _                   = []--packageStatus :: InstalledPackageIndex-              -> ReadyPackage-              -> PackageStatus-packageStatus installedPkgIndex cpkg =-  case PackageIndex.lookupPackageName installedPkgIndex-                                      (packageName cpkg) of-    [] -> NewPackage-    ps ->  case filter ((== mungedId cpkg)-                        . mungedId) (concatMap snd ps) of-      []           -> NewVersion (map fst ps)-      pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs)-                                (changes pkg cpkg)--  where--    changes :: Installed.InstalledPackageInfo-            -> ReadyPackage-            -> [PackageChange]-    changes pkg (ReadyPackage pkg') = filter changed $-      mergeBy (comparing mungedName)-        -- deps of installed pkg-        (resolveInstalledIds $ Installed.depends pkg)-        -- deps of configured pkg-        (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))--    -- convert to source pkg ids via index-    resolveInstalledIds :: [UnitId] -> [MungedPackageId]-    resolveInstalledIds =-        nub-      . sort-      . map mungedId-      . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex)--    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'-    changed _                        = True--printPlan :: Bool -- is dry run-          -> Verbosity-          -> [(ReadyPackage, PackageStatus)]-          -> SourcePackageDb-          -> IO ()-printPlan dryRun verbosity plan sourcePkgDb = case plan of-  []   -> return ()-  pkgs-    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $-        ("In order, the following " ++ wouldWill ++ " be installed:")-      : map showPkgAndReason pkgs-    | otherwise -> notice verbosity $ unlines $-        ("In order, the following " ++ wouldWill-         ++ " be installed (use -v for more details):")-      : map showPkg pkgs-  where-    wouldWill | dryRun    = "would"-              | otherwise = "will"--    showPkg (pkg, _) = prettyShow (packageId pkg) ++-                       showLatest (pkg)--    showPkgAndReason (ReadyPackage pkg', pr) = unwords-        [ prettyShow (packageId pkg')-        , showLatest pkg'-        , showFlagAssignment (nonDefaultFlags pkg')-        , showStanzas (confPkgStanzas pkg')-        , showDep pkg'-        , case pr of-            NewPackage     -> "(new package)"-            NewVersion _   -> "(new version)"-            Reinstall _ cs -> "(reinstall)" ++ case cs of-                []   -> ""-                diff -> "(changes: "  ++ intercalate ", " (map change diff)-                        ++ ")"-        ]--    showLatest :: Package srcpkg => srcpkg -> String-    showLatest pkg = case mLatestVersion of-        Just latestVersion ->-            if packageVersion pkg < latestVersion-            then ("(latest: " ++ prettyShow latestVersion ++ ")")-            else ""-        Nothing -> ""-      where-        mLatestVersion :: Maybe Version-        mLatestVersion = fmap packageVersion $-                         safeLast $-                         SourcePackageIndex.lookupPackageName-                           (packageIndex sourcePkgDb)-                           (packageName pkg)--    toFlagAssignment :: [PackageFlag] -> FlagAssignment-    toFlagAssignment =  mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))--    nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment-    nonDefaultFlags cpkg =-      let defaultAssignment =-            toFlagAssignment-             (genPackageFlags (SourcePackage.srcpkgDescription $-                               confPkgSource cpkg))-      in  confPkgFlags cpkg `diffFlagAssignment` defaultAssignment--    showStanzas :: [OptionalStanza] -> String-    showStanzas = unwords . map (("*" ++) . showStanza)--    change (OnlyInLeft pkgid)        = prettyShow pkgid ++ " removed"-    change (InBoth     pkgid pkgid') = prettyShow pkgid ++ " -> "-                                    ++ prettyShow (mungedVersion pkgid')-    change (OnlyInRight      pkgid') = prettyShow pkgid' ++ " added"--    showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps-                  = " (via: " ++ unwords (map prettyShow rdeps) ++  ")"-                | otherwise = ""--    revDepGraphEdges :: [(PackageId, PackageId)]-    revDepGraphEdges = [ (rpid, packageId cpkg)-                       | (ReadyPackage cpkg, _) <- plan-                       , ConfiguredId-                           rpid-                           (Just-                             (PackageDescription.CLibName-                               PackageDescription.LMainLibName))-                           _-                        <- CD.flatDeps (confPkgDeps cpkg) ]--    revDeps :: Map.Map PackageId [PackageId]-    revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges)---- --------------------------------------------------------------- * Post installation stuff--- ---------------------------------------------------------------- | Report a solver failure. This works slightly differently to--- 'postInstallActions', as (by definition) we don't have an install plan.-reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String-                      -> IO ()-reportPlanningFailure verbosity-  (_, _, comp, platform, _-  ,_, configFlags, _, installFlags, _, _, _)-  (_, sourcePkgDb, _, _, pkgSpecifiers, _)-  message = do--  when reportFailure $ do--    -- Only create reports for explicitly named packages-    let pkgids = filter-          (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $-          mapMaybe theSpecifiedPackage pkgSpecifiers--        buildReports = BuildReports.fromPlanningFailure platform-                       (compilerId comp) pkgids-                       (configConfigurationsFlags configFlags)--    unless (null buildReports) $-      info verbosity $-        "Solver failure will be reported for "-        ++ intercalate "," (map prettyShow pkgids)--    -- Save reports-    BuildReports.storeLocal (compilerInfo comp)-                            (fromNubList $ installSummaryFile installFlags)-                            buildReports platform--    -- Save solver log-    case logFile of-      Nothing -> return ()-      Just template -> for_ pkgids $ \pkgid ->-        let env = initialPathTemplateEnv pkgid dummyIpid-                    (compilerInfo comp) platform-            path = fromPathTemplate $ substPathTemplate env template-        in  writeFile path message--  where-    reportFailure = fromFlag (installReportPlanningFailure installFlags)-    logFile = flagToMaybe (installLogFile installFlags)--    -- A IPID is calculated from the transitive closure of-    -- dependencies, but when the solver fails we don't have that.-    -- So we fail.-    dummyIpid = error "reportPlanningFailure: installed package ID not available"---- | If a 'PackageSpecifier' refers to a single package, return Just that--- package.-theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId-theSpecifiedPackage pkgSpec =-  case pkgSpec of-    NamedPackage name [PackagePropertyVersion version]-      -> PackageIdentifier name <$> trivialRange version-    NamedPackage _ _ -> Nothing-    SpecificSourcePackage pkg -> Just $ packageId pkg-  where-    -- | If a range includes only a single version, return Just that version.-    trivialRange :: VersionRange -> Maybe Version-    trivialRange = foldVersionRange-        Nothing-        Just     -- "== v"-        (\_ -> Nothing)-        (\_ -> Nothing)-        (\_ _ -> Nothing)-        (\_ _ -> Nothing)---- | Various stuff we do after successful or unsuccessfully installing a bunch--- of packages. This includes:------  * build reporting, local and remote---  * symlinking binaries---  * updating indexes---  * updating world file---  * error reporting----postInstallActions :: Verbosity-                   -> InstallArgs-                   -> [UserTarget]-                   -> InstallPlan-                   -> BuildOutcomes-                   -> IO ()-postInstallActions verbosity-  (packageDBs, _, comp, platform, progdb-  ,globalFlags, configFlags, _, installFlags, _, _, _)-  targets installPlan buildOutcomes = do--  unless oneShot $-    World.insert verbosity worldFile-      --FIXME: does not handle flags-      [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty-      | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ]--  let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)-                                                  installPlan buildOutcomes-  BuildReports.storeLocal (compilerInfo comp)-                          (fromNubList $ installSummaryFile installFlags)-                          buildReports-                          platform-  when (reportingLevel >= AnonymousReports) $-    BuildReports.storeAnonymous buildReports-  when (reportingLevel == DetailedReports) $-    storeDetailedBuildReports verbosity logsDir buildReports--  regenerateHaddockIndex verbosity packageDBs comp platform progdb-                         configFlags installFlags buildOutcomes--  symlinkBinaries verbosity platform comp configFlags installFlags-                  installPlan buildOutcomes--  printBuildFailures verbosity buildOutcomes--  where-    reportingLevel = fromFlag (installBuildReports installFlags)-    logsDir        = fromFlag (globalLogsDir globalFlags)-    oneShot        = fromFlag (installOneShot installFlags)-    worldFile      = fromFlag $ globalWorldFile globalFlags--storeDetailedBuildReports :: Verbosity -> FilePath-                          -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()-storeDetailedBuildReports verbosity logsDir reports = sequence_-  [ do dotCabal <- getCabalDir-       let logFileName = prettyShow (BuildReports.package report) <.> "log"-           logFile     = logsDir </> logFileName-           reportsDir  = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)-           reportFile  = reportsDir </> logFileName--       handleMissingLogFile $ do-         buildLog <- readFile logFile-         createDirectoryIfMissing True reportsDir -- FIXME-         writeFile reportFile (show (showBuildReport report, buildLog))--  | (report, Just repo) <- reports-  , Just remoteRepo <- [maybeRepoRemote repo]-  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]--  where-    isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True-    isLikelyToHaveLogFile BuildReports.BuildFailed     {} = True-    isLikelyToHaveLogFile BuildReports.InstallFailed   {} = True-    isLikelyToHaveLogFile BuildReports.InstallOk       {} = True-    isLikelyToHaveLogFile _                               = False--    handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->-      warn verbosity $ "Missing log file for build report: "-                    ++ fromMaybe ""  (ioeGetFileName ioe)--    missingFile ioe-      | isDoesNotExistError ioe  = Just ioe-    missingFile _                = Nothing---regenerateHaddockIndex :: Verbosity-                       -> [PackageDB]-                       -> Compiler-                       -> Platform-                       -> ProgramDb-                       -> ConfigFlags-                       -> InstallFlags-                       -> BuildOutcomes-                       -> IO ()-regenerateHaddockIndex verbosity packageDBs comp platform progdb-                       configFlags installFlags buildOutcomes-  | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do--  defaultDirs <- InstallDirs.defaultInstallDirs-                   (compilerFlavor comp)-                   (fromFlag (configUserInstall configFlags))-                   True-  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)-      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate--  notice verbosity $-     "Updating documentation index " ++ indexFile--  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo-  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-  Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile--  | otherwise = return ()-  where-    haddockIndexFileIsRequested =-         fromFlag (installDocumentation installFlags)-      && isJust (flagToMaybe (installHaddockIndex installFlags))--    -- We want to regenerate the index if some new documentation was actually-    -- installed. Since the index can be only per-user or per-sandbox (see-    -- #1337), we don't do it for global installs or special cases where we're-    -- installing into a specific db.-    shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes-      where-        someDocsWereInstalled = any installedDocs . Map.elems-        installedDocs (Right (BuildResult DocsOk _ _)) = True-        installedDocs _                                = False--        normalUserInstall     = (UserPackageDB `elem` packageDBs)-                             && all (not . isSpecificPackageDB) packageDBs-        isSpecificPackageDB (SpecificPackageDB _) = True-        isSpecificPackageDB _                     = False--    substHaddockIndexFileName defaultDirs = fromPathTemplate-                                          . substPathTemplate env-      where-        env  = env0 ++ installDirsTemplateEnv absoluteDirs-        env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp)-            ++ InstallDirs.platformTemplateEnv platform-            ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform-        absoluteDirs = InstallDirs.substituteInstallDirTemplates-                         env0 templateDirs-        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault-                         defaultDirs (configInstallDirs configFlags)---symlinkBinaries :: Verbosity-                -> Platform -> Compiler-                -> ConfigFlags-                -> InstallFlags-                -> InstallPlan-                -> BuildOutcomes-                -> IO ()-symlinkBinaries verbosity platform comp configFlags installFlags-                plan buildOutcomes = do-  failed <- InstallSymlink.symlinkBinaries platform comp-                                           NeverOverwrite-                                           configFlags installFlags-                                           plan buildOutcomes-  case failed of-    [] -> return ()-    [(_, exe, path)] ->-      warn verbosity $-           "could not create a symlink in " ++ bindir ++ " for "-        ++ prettyShow exe ++ " because the file exists there already but is not "-        ++ "managed by cabal. You can create a symlink for this executable "-        ++ "manually if you wish. The executable file has been installed at "-        ++ path-    exes ->-      warn verbosity $-           "could not create symlinks in " ++ bindir ++ " for "-        ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ]-        ++ " because the files exist there already and are not "-        ++ "managed by cabal. You can create symlinks for these executables "-        ++ "manually if you wish. The executable files have been installed at "-        ++ intercalate ", " [ path | (_, _, path) <- exes ]-  where-    bindir = fromFlag (installSymlinkBinDir installFlags)---printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()-printBuildFailures verbosity buildOutcomes =-  case [ (pkgid, failure)-       | (pkgid, Left failure) <- Map.toList buildOutcomes ] of-    []     -> return ()-    failed -> die' verbosity . unlines-            $ "Error: some packages failed to install:"-            : [ prettyShow pkgid ++ printFailureReason reason-              | (pkgid, reason) <- failed ]-  where-    printFailureReason reason = case reason of-      DependentFailed pkgid -> " depends on " ++ prettyShow pkgid-                            ++ " which failed to install."-      DownloadFailed  e -> " failed while downloading the package."-                        ++ showException e-      UnpackFailed    e -> " failed while unpacking the package."-                        ++ showException e-      ConfigureFailed e -> " failed during the configure step."-                        ++ showException e-      BuildFailed     e -> " failed during the building phase."-                        ++ showException e-      TestsFailed     e -> " failed during the tests phase."-                        ++ showException e-      InstallFailed   e -> " failed during the final install step."-                        ++ showException e--      -- This will never happen, but we include it for completeness-      PlanningFailed -> " failed during the planning phase."--    showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e-#ifdef mingw32_HOST_OS-    maybeOOM _        = ""-#else-    maybeOOM e                    = maybe "" onExitFailure (fromException e)-    onExitFailure (ExitFailure n)-      | n == 9 || n == -9         =-      "\nThis may be due to an out-of-memory condition."-    onExitFailure _               = ""-#endif---- --------------------------------------------------------------- * Actually do the installations--- --------------------------------------------------------------data InstallMisc = InstallMisc {-    libVersion :: Maybe Version-  }---- | If logging is enabled, contains location of the log file and the verbosity--- level for logging.-type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)--performInstallations :: Verbosity-                     -> InstallArgs-                     -> InstalledPackageIndex-                     -> InstallPlan-                     -> IO BuildOutcomes-performInstallations verbosity-  (packageDBs, repoCtxt, comp, platform, progdb,-   globalFlags, configFlags, configExFlags, installFlags,-   haddockFlags, testFlags, _)-  installedPkgIndex installPlan = do--  info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."--  jobControl   <- if parallelInstall then newParallelJobControl numJobs-                                     else newSerialJobControl-  fetchLimit   <- newJobLimit (min numJobs numFetchJobs)-  installLock  <- newLock -- serialise installation-  cacheLock    <- newLock -- serialise access to setup exe cache--  executeInstallPlan verbosity jobControl keepGoing useLogFile-                     installPlan $ \rpkg ->-    installReadyPackage platform cinfo configFlags-                        rpkg $ \configFlags' src pkg pkgoverride ->-      fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->-        installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->-          installUnpackedPackage verbosity installLock numJobs-                                 (setupScriptOptions installedPkgIndex-                                  cacheLock rpkg)-                                 configFlags'-                                 installFlags haddockFlags testFlags-                                 comp progdb-                                 platform pkg rpkg pkgoverride mpath useLogFile--  where-    cinfo = compilerInfo comp--    numJobs         = determineNumJobs (installNumJobs installFlags)-    numFetchJobs    = 2-    parallelInstall = numJobs >= 2-    keepGoing       = fromFlag (installKeepGoing installFlags)-    distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                      (configDistPref configFlags)--    setupScriptOptions index lock rpkg =-      configureSetupScript-        packageDBs-        comp-        platform-        progdb-        distPref-        (chooseCabalVersion configExFlags (libVersion miscOptions))-        (Just lock)-        parallelInstall-        index-        (Just rpkg)--    reportingLevel = fromFlag (installBuildReports installFlags)-    logsDir        = fromFlag (globalLogsDir globalFlags)--    -- Should the build output be written to a log file instead of stdout?-    useLogFile :: UseLogFile-    useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)-                 logFileTemplate-      where-        installLogFile' = flagToMaybe $ installLogFile installFlags-        defaultTemplate = toPathTemplate $-                            logsDir </> "$compiler" </> "$libname" <.> "log"--        -- If the user has specified --remote-build-reporting=detailed, use the-        -- default log file location. If the --build-log option is set, use the-        -- provided location. Otherwise don't use logging, unless building in-        -- parallel (in which case the default location is used).-        logFileTemplate :: Maybe PathTemplate-        logFileTemplate-          | useDefaultTemplate = Just defaultTemplate-          | otherwise          = installLogFile'--        -- If the user has specified --remote-build-reporting=detailed or-        -- --build-log, use more verbose logging.-        loggingVerbosity :: Verbosity-        loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity-                         | otherwise         = verbosity--        useDefaultTemplate :: Bool-        useDefaultTemplate-          | reportingLevel == DetailedReports = True-          | isJust installLogFile'            = False-          | parallelInstall                   = True-          | otherwise                         = False--        overrideVerbosity :: Bool-        overrideVerbosity-          | reportingLevel == DetailedReports = True-          | isJust installLogFile'            = True-          | parallelInstall                   = False-          | otherwise                         = False--    substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath-    substLogFileName template pkg uid = fromPathTemplate-                                  . substPathTemplate env-                                  $ template-      where env = initialPathTemplateEnv (packageId pkg) uid-                    (compilerInfo comp) platform--    miscOptions  = InstallMisc {-      libVersion = flagToMaybe (configCabalVersion configExFlags)-    }---executeInstallPlan :: Verbosity-                   -> JobControl IO (UnitId, BuildOutcome)-                   -> Bool-                   -> UseLogFile-                   -> InstallPlan-                   -> (ReadyPackage -> IO BuildOutcome)-                   -> IO BuildOutcomes-executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =-    InstallPlan.execute-      jobCtl keepGoing depsFailure plan0 $ \pkg -> do-        buildOutcome <- installPkg pkg-        printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome-        return buildOutcome--  where-    depsFailure = DependentFailed . packageId--    -- Print build log if something went wrong, and 'Installed $PKGID'-    -- otherwise.-    printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()-    printBuildResult pkgid uid buildOutcome = case buildOutcome of-        (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid)-        (Left _)  -> do-          notice verbosity $ "Failed to install " ++ prettyShow pkgid-          when (verbosity >= normal) $-            case useLogFile of-              Nothing                 -> return ()-              Just (mkLogFileName, _) -> do-                let logName = mkLogFileName pkgid uid-                putStr $ "Build log ( " ++ logName ++ " ):\n"-                printFile logName--    printFile :: FilePath -> IO ()-    printFile path = readFile path >>= putStr---- | Call an installer for an 'SourcePackage' but override the configure--- 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--- 'configurePackage' in D.C.Configure.-installReadyPackage :: Platform -> CompilerInfo-                    -> ConfigFlags-                    -> ReadyPackage-                    -> (ConfigFlags -> UnresolvedPkgLoc-                                    -> PackageDescription-                                    -> PackageDescriptionOverride-                                    -> a)-                    -> a-installReadyPackage platform cinfo configFlags-                    (ReadyPackage (ConfiguredPackage ipid-                                    (SourcePackage _ gpkg source pkgoverride)-                                    flags stanzas deps))-                    installPkg =-  installPkg configFlags {-    configIPID = toFlag (prettyShow ipid),-    configConfigurationsFlags = flags,-    -- 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  = [ thisPackageVersionConstraint srcid-                         | ConfiguredId-                             srcid-                             (Just-                               (PackageDescription.CLibName-                                 PackageDescription.LMainLibName))-                             _ipid-                            <- CD.nonSetupDeps deps ],-    configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid-                         | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid-                            <- CD.nonSetupDeps deps ],-    -- Use '--exact-configuration' if supported.-    configExactConfiguration = toFlag True,-    configBenchmarks         = toFlag False,-    configTests              = toFlag (TestStanzas `elem` stanzas)-  } source pkg pkgoverride-  where-    pkg = case finalizePD flags (enableStanzas stanzas)-           (const True)-           platform cinfo [] gpkg of-      Left _ -> error "finalizePD ReadyPackage failed"-      Right (desc, _) -> desc--fetchSourcePackage-  :: Verbosity-  -> RepoContext-  -> JobLimit-  -> UnresolvedPkgLoc-  -> (ResolvedPkgLoc -> IO BuildOutcome)-  -> IO BuildOutcome-fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do-  fetched <- checkFetched src-  case fetched of-    Just src' -> installPkg src'-    Nothing   -> onFailure DownloadFailed $ do-                   loc <- withJobLimit fetchLimit $-                            fetchPackage verbosity repoCtxt src-                   installPkg loc---installLocalPackage-  :: Verbosity-  -> PackageIdentifier -> ResolvedPkgLoc -> FilePath-  -> (Maybe FilePath -> IO BuildOutcome)-  -> IO BuildOutcome-installLocalPackage verbosity pkgid location distPref installPkg =--  case location of--    LocalUnpackedPackage dir ->-      installPkg (Just dir)--    RemoteSourceRepoPackage _repo dir ->-      installPkg (Just dir)--    LocalTarballPackage tarballPath ->-      installLocalTarballPackage verbosity-        pkgid tarballPath distPref installPkg--    RemoteTarballPackage _ tarballPath ->-      installLocalTarballPackage verbosity-        pkgid tarballPath distPref installPkg--    RepoTarballPackage _ _ tarballPath ->-      installLocalTarballPackage verbosity-        pkgid tarballPath distPref installPkg--installLocalTarballPackage-  :: Verbosity-  -> PackageIdentifier -> FilePath -> FilePath-  -> (Maybe FilePath -> IO BuildOutcome)-  -> IO BuildOutcome-installLocalTarballPackage verbosity pkgid-                           tarballPath distPref installPkg = do-  tmp <- getTemporaryDirectory-  withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->-    onFailure UnpackFailed $ do-      let relUnpackedPath = prettyShow pkgid-          absUnpackedPath = tmpDirPath </> relUnpackedPath-          descFilePath = absUnpackedPath-                     </> prettyShow (packageName pkgid) <.> "cabal"-      info verbosity $ "Extracting " ++ tarballPath-                    ++ " to " ++ tmpDirPath ++ "..."-      extractTarGzFile tmpDirPath relUnpackedPath tarballPath-      exists <- doesFileExist descFilePath-      unless exists $-        die' verbosity $ "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 a nonstandard build directory name-    -- is used (as is the case with sandboxes), so we need to rename-    -- the 'dist' dir here.-    ---    -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still-    -- fails even with this workaround. We probably can live with that.-    maybeRenameDistDir :: FilePath -> IO ()-    maybeRenameDistDir absUnpackedPath = do-      let distDirPath    = absUnpackedPath </> defaultDistPref-          distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")-          distDirPathNew = absUnpackedPath </> distPref-      distDirExists <- doesDirectoryExist distDirPath-      when (distDirExists-            && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do-        -- NB: we need to handle the case when 'distDirPathNew' is a-        -- subdirectory of 'distDirPath' (e.g. the former is-        -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').-        debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '"-          ++ distDirPathTmp ++ "'."-        renameDirectory distDirPath distDirPathTmp-        when (distDirPath `isPrefixOf` distDirPathNew) $-          createDirectoryIfMissingVerbose verbosity False distDirPath-        debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '"-          ++ distDirPathNew ++ "'."-        renameDirectory distDirPathTmp distDirPathNew--installUnpackedPackage-  :: Verbosity-  -> Lock-  -> Int-  -> SetupScriptOptions-  -> ConfigFlags-  -> InstallFlags-  -> HaddockFlags-  -> TestFlags-  -> Compiler-  -> ProgramDb-  -> Platform-  -> PackageDescription-  -> ReadyPackage-  -> PackageDescriptionOverride-  -> Maybe FilePath -- ^ Directory to change to before starting the installation.-  -> UseLogFile -- ^ File to log output to (if any)-  -> IO BuildOutcome-installUnpackedPackage verbosity installLock numJobs-                       scriptOptions-                       configFlags installFlags haddockFlags testFlags comp progdb-                       platform pkg rpkg pkgoverride workingDir useLogFile = do-  -- Override the .cabal file if necessary-  case pkgoverride of-    Nothing     -> return ()-    Just pkgtxt -> do-      let descFilePath = fromMaybe "." workingDir-                     </> prettyShow (packageName pkgid) <.> "cabal"-      info verbosity $-        "Updating " ++ prettyShow (packageName pkgid) <.> "cabal"-                    ++ " with the latest revision from the index."-      writeFileAtomic descFilePath pkgtxt--  -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if-  -- the setup script was compiled against an old version of the Cabal lib).-  configFlags' <- addDefaultInstallDirs configFlags-  -- Filter out flags not supported by the old versions of the Cabal lib.-  let configureFlags :: Version -> ConfigFlags-      configureFlags  = filterConfigureFlags configFlags' {-        configVerbosity = toFlag verbosity'-      }--  -- Path to the optional log file.-  mLogPath <- maybeLogPath--  logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do-    -- Configure phase-    onFailure ConfigureFailed $ do-      noticeProgress ProgressStarting-      setup configureCommand configureFlags mLogPath--    -- Build phase-      onFailure BuildFailed $ do-        noticeProgress ProgressBuilding-        setup buildCommand' buildFlags mLogPath--    -- Doc generation phase-        docsResult <- if shouldHaddock-          then (do setup haddockCommand haddockFlags' mLogPath-                   return DocsOk)-                 `catchIO`   (\_ -> return DocsFailed)-                 `catchExit` (\_ -> return DocsFailed)-          else return DocsNotTried--    -- Tests phase-        onFailure TestsFailed $ do-          when (testsEnabled && PackageDescription.hasTests pkg) $-              setup Cabal.testCommand testFlags' mLogPath--          let testsResult | testsEnabled = TestsOk-                          | otherwise = TestsNotTried--        -- Install phase-          onFailure InstallFailed $ criticalSection installLock $ do-            -- Actual installation-            withWin32SelfUpgrade verbosity uid configFlags-                                 cinfo platform pkg $ do-              setup Cabal.copyCommand copyFlags mLogPath--            -- Capture installed package configuration file, so that-            -- it can be incorporated into the final InstallPlan-            ipkgs <- genPkgConfs mLogPath-            let ipkgs' = case ipkgs of-                            [ipkg] -> [ipkg { Installed.installedUnitId = uid }]-                            _ -> ipkgs-            let packageDBs = interpretPackageDbFlags-                                (fromFlag (configUserInstall configFlags))-                                (configPackageDBs configFlags)-            for_ ipkgs' $ \ipkg' ->-                registerPackage verbosity comp progdb-                                packageDBs ipkg'-                                defaultRegisterOptions--            return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs')))--  where-    pkgid            = packageId pkg-    uid              = installedUnitId rpkg-    cinfo            = compilerInfo comp-    buildCommand'    = buildCommand progdb-    dispname         = prettyShow pkgid-    isParallelBuild  = numJobs >= 2--    noticeProgress phase = when isParallelBuild $-        progressMessage verbosity phase dispname--    buildFlags   _   = emptyBuildFlags {-      buildDistPref  = configDistPref configFlags,-      buildVerbosity = toFlag verbosity'-    }-    shouldHaddock    = fromFlag (installDocumentation installFlags)-    haddockFlags' _   = haddockFlags {-      haddockVerbosity = toFlag verbosity',-      haddockDistPref  = configDistPref configFlags-    }-    testsEnabled = fromFlag (configTests configFlags)-                   && fromFlagOrDefault False (installRunTests installFlags)-    testFlags' = filterTestFlags testFlags {-      Cabal.testDistPref = configDistPref configFlags-    }-    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 ++ "-" ++ prettyShow pkgid--    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags-    addDefaultInstallDirs configFlags' = do-      defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False-      return $ configFlags' {-          configInstallDirs = fmap Cabal.Flag .-                              InstallDirs.substituteInstallDirTemplates env $-                              InstallDirs.combineInstallDirs fromFlagOrDefault-                              defInstallDirs (configInstallDirs configFlags)-          }-        where-          CompilerId flavor _ = compilerInfoId cinfo-          env         = initialPathTemplateEnv pkgid uid cinfo platform-          userInstall = fromFlagOrDefault defaultUserInstall-                        (configUserInstall configFlags')--    genPkgConfs :: Maybe FilePath-                     -> IO [Installed.InstalledPackageInfo]-    genPkgConfs mLogPath =-      if shouldRegister then do-        tmp <- getTemporaryDirectory-        withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do-          let pkgConfDest = dir </> "pkgConf"-              registerFlags' version = (registerFlags version) {-                Cabal.regGenPkgConf = toFlag (Just pkgConfDest)-              }-          setup Cabal.registerCommand registerFlags' mLogPath-          is_dir <- doesDirectoryExist pkgConfDest-          let notHidden = not . isHidden-              isHidden name = "." `isPrefixOf` name-          if is_dir-            -- Sort so that each prefix of the package-            -- configurations is well formed-            then traverse (readPkgConf pkgConfDest) . sort . filter notHidden-                    =<< getDirectoryContents pkgConfDest-            else fmap (:[]) $ readPkgConf "." pkgConfDest-      else return []--    readPkgConf :: FilePath -> FilePath-                -> IO Installed.InstalledPackageInfo-    readPkgConf pkgConfDir pkgConfFile = do-      pkgConfText <- BS.readFile (pkgConfDir </> pkgConfFile)-      case Installed.parseInstalledPackageInfo pkgConfText of-        Left perrors    -> pkgConfParseFailed $ unlines $ NE.toList perrors-        Right (warns, pkgConf) -> do-          unless (null warns) $-            warn verbosity $ unlines warns-          return pkgConf--    pkgConfParseFailed :: String -> IO a-    pkgConfParseFailed perror =-      die' verbosity $ "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) uid-               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-      (traverse (\path -> openFile path AppendMode) mLogPath)-      (traverse_ hClose)-      (\logFileHandle ->-        setupWrapper verbosity-          scriptOptions { useLoggingHandle = logFileHandle-                        , useWorkingDir    = workingDir }-          (Just pkg)-          cmd flags (const []))----- helper-onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome-onFailure result action =-  action `catches`-    [ Handler $ \ioe  -> handler (ioe  :: IOException)-    , Handler $ \exit -> handler (exit :: ExitCode)-    ]-  where-    handler :: Exception e => e -> IO BuildOutcome-    handler = return . Left . result . toException----- --------------------------------------------------------------- * Weird windows hacks--- --------------------------------------------------------------withWin32SelfUpgrade :: Verbosity-                     -> UnitId-                     -> ConfigFlags-                     -> CompilerInfo-                     -> Platform-                     -> PackageDescription-                     -> IO a -> IO a-withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do--  defaultDirs <- InstallDirs.defaultInstallDirs-                   compFlavor-                   (fromFlag (configUserInstall configFlags))-                   (PackageDescription.hasLibs pkg)--  Win32SelfUpgrade.possibleSelfUpgrade verbosity-    (exeInstallPaths defaultDirs) action--  where-    pkgid = packageId pkg-    (CompilerId compFlavor _) = compilerInfoId cinfo--    exeInstallPaths defaultDirs =-      [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension buildPlatform-      | exe <- PackageDescription.executables pkg-      , PackageDescription.buildable (PackageDescription.buildInfo exe)-      , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix-            prefix  = substTemplate prefixTemplate-            suffix  = substTemplate suffixTemplate ]-      where-        fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")-        prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)-        suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)-        templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault-                           defaultDirs (configInstallDirs configFlags)-        absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid uid-                           cinfo InstallDirs.NoCopyDest-                           platform templateDirs-        substTemplate  = InstallDirs.fromPathTemplate-                       . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid uid-                      cinfo platform
− Distribution/Client/InstallPlan.hs 
@@ -1,957 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.InstallPlan--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org--- Stability   :  provisional--- Portability :  portable------ Package installation plan----------------------------------------------------------------------------------module Distribution.Client.InstallPlan (-  InstallPlan,-  GenericInstallPlan,-  PlanPackage,-  GenericPlanPackage(..),-  foldPlanPackage,-  IsUnit,--  -- * Operations on 'InstallPlan's-  new,-  toGraph,-  toList,-  toMap,-  keys,-  keysSet,-  planIndepGoals,-  depends,--  fromSolverInstallPlan,-  fromSolverInstallPlanWithProgress,-  configureInstallPlan,-  remove,-  installed,-  lookup,-  directDeps,-  revDirectDeps,--  -- * Traversal-  executionOrder,-  execute,-  BuildOutcomes,-  lookupBuildOutcome,-  -- ** Traversal helpers-  -- $traversal-  Processing,-  ready,-  completed,-  failed,--  -- * Display-  showPlanGraph,-  showInstallPlan,--  -- * Graph-like operations-  dependencyClosure,-  reverseTopologicalOrder,-  reverseDependencyClosure,-  ) where--import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail)-import Prelude (tail)-import Distribution.Compat.Stack (WithCallStack)--import Distribution.Client.Types hiding (BuildOutcomes)-import qualified Distribution.PackageDescription as PD-import qualified Distribution.Simple.Configure as Configure-import qualified Distribution.Simple.Setup as Cabal--import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.Package-         ( Package(..), HasMungedPackageId(..)-         , HasUnitId(..), UnitId )-import Distribution.Solver.Types.SolverPackage-import Distribution.Client.JobControl-import Distribution.Pretty (defaultStyle)-import Text.PrettyPrint-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)--import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.SolverId-import           Distribution.Solver.Types.InstSolverPackage--import           Distribution.Utils.LogProgress-import           Distribution.Utils.Structured (Structured (..), Structure(Nominal))---- TODO: Need this when we compute final UnitIds--- import qualified Distribution.Simple.Configure as Configure--import qualified Data.Foldable as Foldable (all, toList)-import qualified Distribution.Compat.Graph as Graph-import Distribution.Compat.Graph (Graph, IsNode(..))-import Control.Exception-         ( assert )-import qualified Data.Map as Map-import qualified Data.Set as Set---- When cabal tries to install a number of packages, including all their--- dependencies it has a non-trivial problem to solve.------ The Problem:------ In general we start with a set of installed packages and a set of source--- packages.------ Installed packages have fixed dependencies. They have already been built and--- we know exactly what packages they were built against, including their exact--- versions.------ Source package have somewhat flexible dependencies. They are specified as--- version ranges, though really they're predicates. To make matters worse they--- have conditional flexible dependencies. Configuration flags can affect which--- packages are required and can place additional constraints on their--- versions.------ These two sets of package can and usually do overlap. There can be installed--- packages that are also available as source packages which means they could--- be re-installed if required, though there will also be packages which are--- not available as source and cannot be re-installed. Very often there will be--- extra versions available than are installed. Sometimes we may like to prefer--- installed packages over source ones or perhaps always prefer the latest--- available version whether installed or not.------ The goal is to calculate an installation plan that is closed, acyclic and--- consistent and where every configured package is valid.------ An installation plan is a set of packages that are going to be used--- together. It will consist of a mixture of installed packages and source--- packages along with their exact version dependencies. An installation plan--- is closed if for every package in the set, all of its dependencies are--- also in the set. It is consistent if for every package in the set, all--- dependencies which target that package have the same version.---- Note that plans do not necessarily compose. You might have a valid plan for--- package A and a valid plan for package B. That does not mean the composition--- is simultaneously valid for A and B. In particular you're most likely to--- have problems with inconsistent dependencies.--- On the other hand it is true that every closed sub plan is valid.---- | Packages in an install plan------ NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'--- intentionally have no 'PackageInstalled' instance. `This is important:--- PackageInstalled returns only library dependencies, but for package that--- aren't yet installed we know many more kinds of dependencies (setup--- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on--- dependencies in cabal-install should consider what to do with these--- dependencies; if we give a 'PackageInstalled' instance it would be too easy--- to get this wrong (and, for instance, call graph traversal functions from--- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.-data GenericPlanPackage ipkg srcpkg-   = PreExisting ipkg-   | Configured  srcpkg-   | Installed   srcpkg-  deriving (Eq, Show, Generic)--displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String-displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)-displayGenericPlanPackage (Configured pkg)  = "Configured " ++ prettyShow (nodeKey pkg)-displayGenericPlanPackage (Installed pkg)   = "Installed " ++ prettyShow (nodeKey pkg)---- | Convenience combinator for destructing 'GenericPlanPackage'.--- This is handy because if you case manually, you have to handle--- 'Configured' and 'Installed' separately (where often you want--- them to be the same.)-foldPlanPackage :: (ipkg -> a)-                -> (srcpkg -> a)-                -> GenericPlanPackage ipkg srcpkg-                -> a-foldPlanPackage f _ (PreExisting ipkg)  = f ipkg-foldPlanPackage _ g (Configured srcpkg) = g srcpkg-foldPlanPackage _ g (Installed  srcpkg) = g srcpkg--type IsUnit a = (IsNode a, Key a ~ UnitId)--depends :: IsUnit a => a -> [UnitId]-depends = nodeNeighbors---- NB: Expanded constraint synonym here to avoid undecidable--- instance errors in GHC 7.8 and earlier.-instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)-         => IsNode (GenericPlanPackage ipkg srcpkg) where-    type Key (GenericPlanPackage ipkg srcpkg) = UnitId-    nodeKey (PreExisting ipkg) = nodeKey ipkg-    nodeKey (Configured  spkg) = nodeKey spkg-    nodeKey (Installed   spkg) = nodeKey spkg-    nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg-    nodeNeighbors (Configured  spkg) = nodeNeighbors spkg-    nodeNeighbors (Installed   spkg) = nodeNeighbors spkg--instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)-instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg)--type PlanPackage = GenericPlanPackage-                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)--instance (Package ipkg, Package srcpkg) =>-         Package (GenericPlanPackage ipkg srcpkg) where-  packageId (PreExisting ipkg)     = packageId ipkg-  packageId (Configured  spkg)     = packageId spkg-  packageId (Installed   spkg)     = packageId spkg--instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) =>-         HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where-  mungedId (PreExisting ipkg)     = mungedId ipkg-  mungedId (Configured  spkg)     = mungedId spkg-  mungedId (Installed   spkg)     = mungedId spkg--instance (HasUnitId ipkg, HasUnitId srcpkg) =>-         HasUnitId-         (GenericPlanPackage ipkg srcpkg) where-  installedUnitId (PreExisting ipkg) = installedUnitId ipkg-  installedUnitId (Configured  spkg) = installedUnitId spkg-  installedUnitId (Installed   spkg) = installedUnitId spkg--instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>-          HasConfiguredId (GenericPlanPackage ipkg srcpkg) where-    configuredId (PreExisting ipkg) = configuredId ipkg-    configuredId (Configured  spkg) = configuredId spkg-    configuredId (Installed   spkg) = configuredId spkg--data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {-    planGraph      :: !(Graph (GenericPlanPackage ipkg srcpkg)),-    planIndepGoals :: !IndependentGoals-  }-  deriving (Typeable)---- | 'GenericInstallPlan' specialised to most commonly used types.-type InstallPlan = GenericInstallPlan-                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)---- | Smart constructor that deals with caching the 'Graph' representation.----mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)-              => String-              -> Graph (GenericPlanPackage ipkg srcpkg)-              -> IndependentGoals-              -> GenericInstallPlan ipkg srcpkg-mkInstallPlan loc graph indepGoals =-    assert (valid loc graph)-    GenericInstallPlan {-      planGraph      = graph,-      planIndepGoals = indepGoals-    }--internalError :: WithCallStack (String -> String -> a)-internalError loc msg = error $ "internal error in InstallPlan." ++ loc-                             ++ if null msg then "" else ": " ++ msg--instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where-    structure p = Nominal (typeRep p) 0 "GenericInstallPlan"-        [ structure (Proxy :: Proxy ipkg)-        , structure (Proxy :: Proxy srcpkg)-        ]--instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,-          Binary ipkg, Binary srcpkg)-       => Binary (GenericInstallPlan ipkg srcpkg) where-    put GenericInstallPlan {-              planGraph      = graph,-              planIndepGoals = indepGoals-        } = put graph >> put indepGoals--    get = do-      graph <- get-      indepGoals <- get-      return $! mkInstallPlan "(instance Binary)" graph indepGoals--showPlanGraph :: (Package ipkg, Package srcpkg,-                  IsUnit ipkg, IsUnit srcpkg)-              => Graph (GenericPlanPackage ipkg srcpkg) -> String-showPlanGraph graph = renderStyle defaultStyle $-    vcat (map dispPlanPackage (Foldable.toList graph))-  where dispPlanPackage p =-            hang (hsep [ text (showPlanPackageTag p)-                       , pretty (packageId p)-                       , parens (pretty (nodeKey p))]) 2-                 (vcat (map pretty (nodeNeighbors p)))--showInstallPlan :: (Package ipkg, Package srcpkg,-                    IsUnit ipkg, IsUnit srcpkg)-                => GenericInstallPlan ipkg srcpkg -> String-showInstallPlan = showPlanGraph . planGraph--showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String-showPlanPackageTag (PreExisting _)   = "PreExisting"-showPlanPackageTag (Configured  _)   = "Configured"-showPlanPackageTag (Installed   _)   = "Installed"---- | Build an installation plan from a valid set of resolved packages.----new :: (IsUnit ipkg, IsUnit srcpkg)-    => IndependentGoals-    -> Graph (GenericPlanPackage ipkg srcpkg)-    -> GenericInstallPlan ipkg srcpkg-new indepGoals graph = mkInstallPlan "new" graph indepGoals--toGraph :: GenericInstallPlan ipkg srcpkg-        -> Graph (GenericPlanPackage ipkg srcpkg)-toGraph = planGraph--toList :: GenericInstallPlan ipkg srcpkg-       -> [GenericPlanPackage ipkg srcpkg]-toList = Foldable.toList . planGraph--toMap :: GenericInstallPlan ipkg srcpkg-      -> Map UnitId (GenericPlanPackage ipkg srcpkg)-toMap = Graph.toMap . planGraph--keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]-keys = Graph.keys . planGraph--keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId-keysSet = Graph.keysSet . planGraph---- | Remove packages from the install plan. This will result in an--- error if there are remaining packages that depend on any matching--- package. This is primarily useful for obtaining an install plan for--- the dependencies of a package or set of packages without actually--- installing the package itself, as when doing development.----remove :: (IsUnit ipkg, IsUnit srcpkg)-       => (GenericPlanPackage ipkg srcpkg -> Bool)-       -> GenericInstallPlan ipkg srcpkg-       -> GenericInstallPlan ipkg srcpkg-remove shouldRemove plan =-    mkInstallPlan "remove" newGraph (planIndepGoals plan)-  where-    newGraph = Graph.fromDistinctList $-                 filter (not . shouldRemove) (toList plan)---- | Change a number of packages in the 'Configured' state to the 'Installed'--- state.------ To preserve invariants, the package must have all of its dependencies--- already installed too (that is 'PreExisting' or 'Installed').----installed :: (IsUnit ipkg, IsUnit srcpkg)-          => (srcpkg -> Bool)-          -> GenericInstallPlan ipkg srcpkg-          -> GenericInstallPlan ipkg srcpkg-installed shouldBeInstalled installPlan =-    foldl' markInstalled installPlan-      [ pkg-      | Configured pkg <- reverseTopologicalOrder installPlan-      , shouldBeInstalled pkg ]-  where-    markInstalled plan pkg =-      assert (all isInstalled (directDeps plan (nodeKey pkg))) $-      plan {-        planGraph = Graph.insert (Installed pkg) (planGraph plan)-      }---- | Lookup a package in the plan.----lookup :: (IsUnit ipkg, IsUnit srcpkg)-       => GenericInstallPlan ipkg srcpkg-       -> UnitId-       -> Maybe (GenericPlanPackage ipkg srcpkg)-lookup plan pkgid = Graph.lookup pkgid (planGraph plan)---- | Find all the direct dependencies of the given package.------ Note that the package must exist in the plan or it is an error.----directDeps :: GenericInstallPlan ipkg srcpkg-           -> UnitId-           -> [GenericPlanPackage ipkg srcpkg]-directDeps plan pkgid =-  case Graph.neighbors (planGraph plan) pkgid of-    Just deps -> deps-    Nothing   -> internalError "directDeps" "package not in graph"---- | Find all the direct reverse dependencies of the given package.------ Note that the package must exist in the plan or it is an error.----revDirectDeps :: GenericInstallPlan ipkg srcpkg-              -> UnitId-              -> [GenericPlanPackage ipkg srcpkg]-revDirectDeps plan pkgid =-  case Graph.revNeighbors (planGraph plan) pkgid of-    Just deps -> deps-    Nothing   -> internalError "revDirectDeps" "package not in graph"---- | Return all the packages in the 'InstallPlan' in reverse topological order.--- That is, for each package, all dependencies of the package appear first.------ Compared to 'executionOrder', this function returns all the installed and--- source packages rather than just the source ones. Also, while both this--- and 'executionOrder' produce reverse topological orderings of the package--- dependency graph, it is not necessarily exactly the same order.----reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg-                        -> [GenericPlanPackage ipkg srcpkg]-reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)----- | Return the packages in the plan that are direct or indirect dependencies of--- the given packages.----dependencyClosure :: GenericInstallPlan ipkg srcpkg-                  -> [UnitId]-                  -> [GenericPlanPackage ipkg srcpkg]-dependencyClosure plan = fromMaybe []-                       . Graph.closure (planGraph plan)---- | Return the packages in the plan that depend directly or indirectly on the--- given packages.----reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg-                         -> [UnitId]-                         -> [GenericPlanPackage ipkg srcpkg]-reverseDependencyClosure plan = fromMaybe []-                              . Graph.revClosure (planGraph plan)----- Alert alert!   Why does SolverId map to a LIST of plan packages?--- The sordid story has to do with 'build-depends' on a package--- with libraries and executables.  In an ideal world, we would--- ONLY depend on the library in this situation.  But c.f. #3661--- some people rely on the build-depends to ALSO implicitly--- depend on an executable.------ I don't want to commit to a strategy yet, so the only possible--- thing you can do in this case is return EVERYTHING and let--- the client filter out what they want (executables? libraries?--- etc).  This similarly implies we can't return a 'ConfiguredId'--- because that's not enough information.--fromSolverInstallPlan ::-      (IsUnit ipkg, IsUnit srcpkg)-    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])-        -> SolverInstallPlan.SolverPlanPackage-        -> [GenericPlanPackage ipkg srcpkg]         )-    -> SolverInstallPlan-    -> GenericInstallPlan ipkg srcpkg-fromSolverInstallPlan f plan =-    mkInstallPlan "fromSolverInstallPlan"-      (Graph.fromDistinctList pkgs'')-      (SolverInstallPlan.planIndepGoals plan)-  where-    (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])-                        (SolverInstallPlan.reverseTopologicalOrder plan)--    f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)-      where-       pkgs' = f (mapDep pidMap ipiMap) pkg--       (pidMap', ipiMap')-         = case nodeKey pkg of-            PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)-            PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)--    mapDep _ ipiMap (PreExistingId _pid uid)-        | Just pkgs <- Map.lookup uid ipiMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)-    mapDep pidMap _ (PlannedId pid)-        | Just pkgs <- Map.lookup pid pidMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)-    -- This shouldn't happen, since mapDep should only be called-    -- on neighbor SolverId, which must have all been done already-    -- by the reverse top-sort (we assume the graph is not broken).---fromSolverInstallPlanWithProgress ::-      (IsUnit ipkg, IsUnit srcpkg)-    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])-        -> SolverInstallPlan.SolverPlanPackage-        -> LogProgress [GenericPlanPackage ipkg srcpkg]         )-    -> SolverInstallPlan-    -> LogProgress (GenericInstallPlan ipkg srcpkg)-fromSolverInstallPlanWithProgress f plan = do-    (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])-                        (SolverInstallPlan.reverseTopologicalOrder plan)-    return $ mkInstallPlan "fromSolverInstallPlanWithProgress"-               (Graph.fromDistinctList pkgs'')-               (SolverInstallPlan.planIndepGoals plan)-  where-    f' (pidMap, ipiMap, pkgs) pkg = do-        pkgs' <- f (mapDep pidMap ipiMap) pkg-        let (pidMap', ipiMap')-                 = case nodeKey pkg of-                    PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)-                    PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)-        return (pidMap', ipiMap', pkgs' ++ pkgs)--    mapDep _ ipiMap (PreExistingId _pid uid)-        | Just pkgs <- Map.lookup uid ipiMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)-    mapDep pidMap _ (PlannedId pid)-        | Just pkgs <- Map.lookup pid pidMap = pkgs-        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)-    -- This shouldn't happen, since mapDep should only be called-    -- on neighbor SolverId, which must have all been done already-    -- by the reverse top-sort (we assume the graph is not broken).---- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.--- Similar to 'elaboratedInstallPlan'-configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan-configureInstallPlan configFlags solverPlan =-    flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->-      [case planpkg of-        SolverInstallPlan.PreExisting pkg ->-          PreExisting (instSolverPkgIPI pkg)--        SolverInstallPlan.Configured  pkg ->-          Configured (configureSolverPackage mapDep pkg)-      ]-  where-    configureSolverPackage :: (SolverId -> [PlanPackage])-                           -> SolverPackage UnresolvedPkgLoc-                           -> ConfiguredPackage UnresolvedPkgLoc-    configureSolverPackage mapDep spkg =-      ConfiguredPackage {-        confPkgId = Configure.computeComponentId-                        (Cabal.fromFlagOrDefault False-                            (Cabal.configDeterministic configFlags))-                        Cabal.NoFlag-                        Cabal.NoFlag-                        (packageId spkg)-                        (PD.CLibName PD.LMainLibName)-                        (Just (map confInstId (CD.libraryDeps deps),-                               solverPkgFlags spkg)),-        confPkgSource = solverPkgSource spkg,-        confPkgFlags  = solverPkgFlags spkg,-        confPkgStanzas = solverPkgStanzas spkg,-        confPkgDeps   = deps-        -- NB: no support for executable dependencies-      }-      where-        deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg)----- --------------------------------------------------------------- * Primitives for traversing plans--- ---------------------------------------------------------------- $traversal------ Algorithms to traverse or execute an 'InstallPlan', especially in parallel,--- may make use of the 'Processing' type and the associated operations--- 'ready', 'completed' and 'failed'.------ The 'Processing' type is used to keep track of the state of a traversal and--- includes the set of packages that are in the processing state, e.g. in the--- process of being installed, plus those that have been completed and those--- where processing failed.------ Traversal algorithms start with an 'InstallPlan':------ * Initially there will be certain packages that can be processed immediately---   (since they are configured source packages and have all their dependencies---   installed already). The function 'ready' returns these packages plus a---   'Processing' state that marks these same packages as being in the---   processing state.------ * The algorithm must now arrange for these packages to be processed---   (possibly in parallel). When a package has completed processing, the---   algorithm needs to know which other packages (if any) are now ready to---   process as a result. The 'completed' function marks a package as completed---   and returns any packages that are newly in the processing state (ie ready---   to process), along with the updated 'Processing' state.------ * If failure is possible then when processing a package fails, the algorithm---   needs to know which other packages have also failed as a result. The---   'failed' function marks the given package as failed as well as all the---   other packages that depend on the failed package. In addition it returns---   the other failed packages.----- | The 'Processing' type is used to keep track of the state of a traversal--- and includes the set of packages that are in the processing state, e.g. in--- the process of being installed, plus those that have been completed and--- those where processing failed.----data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)-                            -- processing,   completed,    failed---- | The packages in the plan that are initially ready to be installed.--- That is they are in the configured state and have all their dependencies--- installed already.------ The result is both the packages that are now ready to be installed and also--- a 'Processing' state containing those same packages. The assumption is that--- all the packages that are ready will now be processed and so we can consider--- them to be in the processing state.----ready :: (IsUnit ipkg, IsUnit srcpkg)-      => GenericInstallPlan ipkg srcpkg-      -> ([GenericReadyPackage srcpkg], Processing)-ready plan =-    assert (processingInvariant plan processing) $-    (readyPackages, processing)-  where-    !processing =-      Processing-        (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])-        (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])-        Set.empty-    readyPackages =-      [ ReadyPackage pkg-      | Configured pkg <- toList plan-      , all isInstalled (directDeps plan (nodeKey pkg))-      ]--isInstalled :: GenericPlanPackage a b -> Bool-isInstalled (PreExisting {}) = True-isInstalled (Installed   {}) = True-isInstalled _                = False---- | Given a package in the processing state, mark the package as completed--- and return any packages that are newly in the processing state (ie ready to--- process), along with the updated 'Processing' state.----completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg)-          => GenericInstallPlan ipkg srcpkg-          -> Processing -> UnitId-          -> ([GenericReadyPackage srcpkg], Processing)-completed plan (Processing processingSet completedSet failedSet) pkgid =-    assert (pkgid `Set.member` processingSet) $-    assert (processingInvariant plan processing') $--    ( map asReadyPackage newlyReady-    , processing' )-  where-    completedSet'  = Set.insert pkgid completedSet--    -- each direct reverse dep where all direct deps are completed-    newlyReady     = [ dep-                     | dep <- revDirectDeps plan pkgid-                     , all ((`Set.member` completedSet') . nodeKey)-                           (directDeps plan (nodeKey dep))-                     ]--    processingSet' = foldl' (flip Set.insert)-                            (Set.delete pkgid processingSet)-                            (map nodeKey newlyReady)-    processing'    = Processing processingSet' completedSet' failedSet--    asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg-    asReadyPackage (Configured pkg)  = ReadyPackage pkg-    asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg--failed :: (IsUnit ipkg, IsUnit srcpkg)-       => GenericInstallPlan ipkg srcpkg-       -> Processing -> UnitId-       -> ([srcpkg], Processing)-failed plan (Processing processingSet completedSet failedSet) pkgid =-    assert (pkgid `Set.member` processingSet) $-    assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $-    assert (all (`Set.notMember` completedSet)  (tail newlyFailedIds)) $-    -- but note that some newlyFailed may already be in the failed set-    -- since one package can depend on two packages that both fail and-    -- so would be in the rev-dep closure for both.-    assert (processingInvariant plan processing') $--    ( map asConfiguredPackage (tail newlyFailed)-    , processing' )-  where-    processingSet' = Set.delete pkgid processingSet-    failedSet'     = failedSet `Set.union` Set.fromList newlyFailedIds-    newlyFailedIds = map nodeKey newlyFailed-    newlyFailed    = fromMaybe (internalError "failed" "package not in graph")-                   $ Graph.revClosure (planGraph plan) [pkgid]-    processing'    = Processing processingSet' completedSet failedSet'--    asConfiguredPackage (Configured pkg) = pkg-    asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg--processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)-                    => GenericInstallPlan ipkg srcpkg-                    -> Processing -> Bool-processingInvariant plan (Processing processingSet completedSet failedSet) =--    -- All the packages in the three sets are actually in the graph-    assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $-    assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $-    assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $--    -- The processing, completed and failed sets are disjoint from each other-    assert (noIntersection processingSet completedSet) $-    assert (noIntersection processingSet failedSet) $-    assert (noIntersection failedSet     completedSet) $--    -- Packages that depend on a package that's still processing cannot be-    -- completed-    assert (noIntersection (reverseClosure processingSet) completedSet) $--    -- On the other hand, packages that depend on a package that's still-    -- processing /can/ have failed (since they may have depended on multiple-    -- packages that were processing, but it only takes one to fail to cause-    -- knock-on failures) so it is quite possible to have an-    -- intersection (reverseClosure processingSet) failedSet--    -- The failed set is upwards closed, i.e. equal to its own rev dep closure-    assert (failedSet == reverseClosure failedSet) $--    -- All immediate reverse deps of packges that are currently processing-    -- are not currently being processed (ie not in the processing set).-    assert (and [ rdeppkgid `Set.notMember` processingSet-                | pkgid     <- Set.toList processingSet-                , rdeppkgid <- maybe (internalError "processingInvariant" "")-                                     (map nodeKey)-                                     (Graph.revNeighbors (planGraph plan) pkgid)-                ]) $--    -- Packages from the processing or failed sets are only ever in the-    -- configured state.-    assert (and [ case Graph.lookup pkgid (planGraph plan) of-                    Just (Configured  _) -> True-                    Just (PreExisting _) -> False-                    Just (Installed   _) -> False-                    Nothing              -> False-                | pkgid <- Set.toList processingSet ++ Set.toList failedSet ])--    -- We use asserts rather than returning False so that on failure we get-    -- better details on which bit of the invariant was violated.-    True-  where-    reverseClosure    = Set.fromList-                      . map nodeKey-                      . fromMaybe (internalError "processingInvariant" "")-                      . Graph.revClosure (planGraph plan)-                      . Set.toList-    noIntersection a b = Set.null (Set.intersection a b)----- --------------------------------------------------------------- * Traversing plans--- ---------------------------------------------------------------- | Flatten an 'InstallPlan', producing the sequence of source packages in--- the order in which they would be processed when the plan is executed. This--- can be used for simultations or presenting execution dry-runs.------ It is guaranteed to give the same order as using 'execute' (with a serial--- in-order 'JobControl'), which is a reverse topological orderings of the--- source packages in the dependency graph, albeit not necessarily exactly the--- same ordering as that produced by 'reverseTopologicalOrder'.----executionOrder :: (IsUnit ipkg, IsUnit srcpkg)-               => GenericInstallPlan ipkg srcpkg-               -> [GenericReadyPackage srcpkg]-executionOrder plan =-    let (newpkgs, processing) = ready plan-     in tryNewTasks processing newpkgs-  where-    tryNewTasks _processing []       = []-    tryNewTasks  processing (p:todo) = waitForTasks processing p todo--    waitForTasks processing p todo =-        p : tryNewTasks processing' (todo++nextpkgs)-      where-        (nextpkgs, processing') = completed plan processing (nodeKey p)----- --------------------------------------------------------------- * Executing plans--- ---------------------------------------------------------------- | The set of results we get from executing an install plan.----type BuildOutcomes failure result = Map UnitId (Either failure result)---- | Lookup the build result for a single package.----lookupBuildOutcome :: HasUnitId pkg-                   => pkg -> BuildOutcomes failure result-                   -> Maybe (Either failure result)-lookupBuildOutcome = Map.lookup . installedUnitId---- | Execute an install plan. This traverses the plan in dependency order.------ Executing each individual package can fail and if so all dependents fail--- too. The result for each package is collected as a 'BuildOutcomes' map.------ Visiting each package happens with optional parallelism, as determined by--- the 'JobControl'. By default, after any failure we stop as soon as possible--- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour--- can be reversed to keep going and build as many packages as possible.------ Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages--- in the plan. In particular in the default mode where we stop as soon as--- possible after a failure then there may be packages which are skipped and--- these will have no 'BuildOutcome'.----execute :: forall m ipkg srcpkg result failure.-           (IsUnit ipkg, IsUnit srcpkg,-            Monad m)-        => JobControl m (UnitId, Either failure result)-        -> Bool                -- ^ Keep going after failure-        -> (srcpkg -> failure) -- ^ Value for dependents of failed packages-        -> GenericInstallPlan ipkg srcpkg-        -> (GenericReadyPackage srcpkg -> m (Either failure result))-        -> m (BuildOutcomes failure result)-execute jobCtl keepGoing depFailure plan installPkg =-    let (newpkgs, processing) = ready plan-     in tryNewTasks Map.empty False False processing newpkgs-  where-    tryNewTasks :: BuildOutcomes failure result-                -> Bool -> Bool -> Processing-                -> [GenericReadyPackage srcpkg]-                -> m (BuildOutcomes failure result)--    tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs-      -- we were in the process of cancelling and now we're finished-      | tasksFailed && not keepGoing && not tasksRemaining-      = return results--      -- we are still in the process of cancelling, wait for remaining tasks-      | tasksFailed && not keepGoing && tasksRemaining-      = waitForTasks results tasksFailed processing--      -- no new tasks to do and all tasks are done so we're finished-      | null newpkgs && not tasksRemaining-      = return results--      -- no new tasks to do, remaining tasks to wait for-      | null newpkgs-      = waitForTasks results tasksFailed processing--      -- new tasks to do, spawn them, then wait for tasks to complete-      | otherwise-      = do sequence_ [ spawnJob jobCtl $ do-                         result <- installPkg pkg-                         return (nodeKey pkg, result)-                     | pkg <- newpkgs ]-           waitForTasks results tasksFailed processing--    waitForTasks :: BuildOutcomes failure result-                 -> Bool -> Processing-                 -> m (BuildOutcomes failure result)-    waitForTasks !results tasksFailed !processing = do-      (pkgid, result) <- collectJob jobCtl--      case result of--        Right _success -> do-            tasksRemaining <- remainingJobs jobCtl-            tryNewTasks results' tasksFailed tasksRemaining-                        processing' nextpkgs-          where-            results' = Map.insert pkgid result results-            (nextpkgs, processing') = completed plan processing pkgid--        Left _failure -> do-            -- if this is the first failure and we're not trying to keep going-            -- then try to cancel as many of the remaining jobs as possible-            when (not tasksFailed && not keepGoing) $-              cancelJobs jobCtl--            tasksRemaining <- remainingJobs jobCtl-            tryNewTasks results' True tasksRemaining processing' []-          where-            (depsfailed, processing') = failed plan processing pkgid-            results'   = Map.insert pkgid result results `Map.union` depResults-            depResults = Map.fromList-                           [ (nodeKey deppkg, Left (depFailure deppkg))-                           | deppkg <- depsfailed ]---- --------------------------------------------------------------- * Checking validity of plans--- ---------------------------------------------------------------- | A valid installation plan is a set of packages that is closed, acyclic--- and respects the package state relation.------ * if the result is @False@ use 'problems' to get a detailed list.----valid :: (IsUnit ipkg, IsUnit srcpkg)-      => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool-valid loc graph =-    case problems graph of-      [] -> True-      ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))--data PlanProblem ipkg srcpkg =-     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg) [UnitId]-   | PackageCycle         [GenericPlanPackage ipkg srcpkg]-   | PackageStateInvalid  (GenericPlanPackage ipkg srcpkg)-                          (GenericPlanPackage ipkg srcpkg)--showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)-                => PlanProblem ipkg srcpkg -> String-showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ prettyShow (nodeKey pkg)-  ++ " depends on the following packages which are missing from the plan: "-  ++ intercalate ", " (map prettyShow missingDeps)--showPlanProblem (PackageCycle cycleGroup) =-     "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)-showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ prettyShow (nodeKey pkg)-  ++ " is in the " ++ showPlanPackageTag pkg-  ++ " state but it depends on package " ++ prettyShow (nodeKey pkg')-  ++ " which is in the " ++ showPlanPackageTag pkg'-  ++ " state"---- | For an invalid plan, produce a detailed list of problems as human readable--- error messages. This is mainly intended for debugging purposes.--- Use 'showPlanProblem' for a human readable explanation.----problems :: (IsUnit ipkg, IsUnit srcpkg)-         => Graph (GenericPlanPackage ipkg srcpkg)-         -> [PlanProblem ipkg srcpkg]-problems graph =--     [ PackageMissingDeps pkg-       (mapMaybe-         (fmap nodeKey . flip Graph.lookup graph)-         missingDeps)-     | (pkg, missingDeps) <- Graph.broken graph ]--  ++ [ PackageCycle cycleGroup-     | cycleGroup <- Graph.cycles graph ]-{--  ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <--       dependencyInconsistencies indepGoals graph ]-     --TODO: consider re-enabling this one, see SolverInstallPlan--}-  ++ [ PackageStateInvalid pkg pkg'-     | pkg <- Foldable.toList graph-     , Just pkg' <- map (flip Graph.lookup graph)-                    (nodeNeighbors pkg)-     , not (stateDependencyRelation pkg pkg') ]---- | The states of packages have that depend on each other must respect--- this relation. That is for very case where package @a@ depends on--- package @b@ we require that @stateDependencyRelation a b = True@.----stateDependencyRelation :: GenericPlanPackage ipkg srcpkg-                        -> GenericPlanPackage ipkg srcpkg -> Bool-stateDependencyRelation PreExisting{} PreExisting{} = True--stateDependencyRelation Installed{}   PreExisting{} = True-stateDependencyRelation Installed{}   Installed{}   = True--stateDependencyRelation Configured{}  PreExisting{} = True-stateDependencyRelation Configured{}  Installed{}   = True-stateDependencyRelation Configured{}  Configured{}  = True--stateDependencyRelation _             _             = False
− Distribution/Client/InstallSymlink.hs 
@@ -1,274 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.InstallSymlink--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Managing installing binaries with symlinks.-------------------------------------------------------------------------------module Distribution.Client.InstallSymlink (-    symlinkBinaries,-    symlinkBinary,-    trySymlink,-  ) where--import Distribution.Client.Compat.Prelude hiding (ioError)-import Prelude ()--import Distribution.Client.Types-         ( ConfiguredPackage(..), BuildOutcomes )-import Distribution.Client.Setup-         ( InstallFlags(installSymlinkBinDir) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)--import Distribution.Solver.Types.SourcePackage-import Distribution.Solver.Types.OptionalStanza--import Distribution.Package-         ( PackageIdentifier, Package(packageId), UnitId, installedUnitId )-import Distribution.Types.UnqualComponentName-import Distribution.Compiler-         ( CompilerId(..) )-import qualified Distribution.PackageDescription as PackageDescription-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.PackageDescription.Configuration-         ( finalizePD )-import Distribution.Simple.Setup-         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )-import qualified Distribution.Simple.InstallDirs as InstallDirs-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, CompilerInfo(..) )-import Distribution.System-         ( Platform )-import Distribution.Simple.Utils ( info, withTempDirectory )--import System.Directory-         ( canonicalizePath, getTemporaryDirectory, removeFile )-import System.FilePath-         ( (</>), splitPath, joinPath, isAbsolute )--import System.IO.Error-         ( isDoesNotExistError, ioError )-import Control.Exception-         ( assert )--import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )-import Distribution.Client.Types.OverwritePolicy--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8---- | We would like by default to install binaries into some location that is on--- the user's PATH. For per-user installations on Unix systems that basically--- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@--- 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 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--- 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--- with symlinks so is not available to Windows users.----symlinkBinaries :: Platform -> Compiler-                -> OverwritePolicy-                -> ConfigFlags-                -> InstallFlags-                -> InstallPlan-                -> BuildOutcomes-                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]-symlinkBinaries platform comp overwritePolicy-                configFlags installFlags-                plan buildOutcomes =-  case flagToMaybe (installSymlinkBinDir installFlags) of-    Nothing            -> return []-    Just symlinkBinDir-           | null exes -> return []-           | otherwise -> do-      publicBinDir  <- canonicalizePath symlinkBinDir---    TODO: do we want to do this here? :---      createDirectoryIfMissing True publicBinDir-      fmap catMaybes $ sequenceA-        [ do privateBinDir <- pkgBinDir pkg ipid-             ok <- symlinkBinary-                     overwritePolicy-                     publicBinDir  privateBinDir-                     (prettyShow publicExeName) privateExeName-             if ok-               then return Nothing-               else return (Just (pkgid, publicExeName,-                                  privateBinDir </> privateExeName))-        | (rpkg, pkg, exe) <- exes-        , let pkgid  = packageId pkg-              -- This is a bit dodgy; probably won't work for Backpack packages-              ipid = installedUnitId rpkg-              publicExeName  = PackageDescription.exeName exe-              privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix-              prefix = substTemplate pkgid ipid prefixTemplate-              suffix = substTemplate pkgid ipid suffixTemplate ]-  where-    exes =-      [ (cpkg, pkg, exe)-      | InstallPlan.Configured cpkg <- InstallPlan.toList plan-      , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of-          Just (Right _success) -> True-          _                     -> False-      , let pkg :: PackageDescription-            pkg = pkgDescription cpkg-      , exe <- PackageDescription.executables pkg-      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]--    pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _)-                                      flags stanzas _) =-      case finalizePD flags (enableStanzas stanzas)-             (const True)-             platform cinfo [] gpd of-        Left _ -> error "finalizePD ReadyPackage failed"-        Right (desc, _) -> desc--    -- This is sadly rather complicated. We're kind of re-doing part of the-    -- configuration for the package. :-(-    pkgBinDir :: PackageDescription -> UnitId -> IO FilePath-    pkgBinDir pkg ipid = do-      defaultDirs <- InstallDirs.defaultInstallDirs-                       compilerFlavor-                       (fromFlag (configUserInstall configFlags))-                       (PackageDescription.hasLibs pkg)-      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault-                           defaultDirs (configInstallDirs configFlags)-          absoluteDirs = InstallDirs.absoluteInstallDirs-                           (packageId pkg) ipid-                           cinfo InstallDirs.NoCopyDest-                           platform templateDirs-      canonicalizePath (InstallDirs.bindir absoluteDirs)--    substTemplate pkgid ipid = InstallDirs.fromPathTemplate-                             . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid ipid-                                                     cinfo platform--    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")-    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)-    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)-    cinfo            = compilerInfo comp-    (CompilerId compilerFlavor _) = compilerInfoId cinfo---- | Symlink binary.------ The paths are take in pieces, so we can make relative link when possible.----symlinkBinary ::-  OverwritePolicy        -- ^ Whether to force overwrite an existing file-  -> FilePath            -- ^ The canonical path of the public bin dir eg-                         --   @/home/user/bin@-  -> FilePath            -- ^ The canonical path of the private bin dir eg-                         --   @/home/user/.cabal/bin@-  -> FilePath            -- ^ The name of the executable to go in the public bin-                         --   dir, eg @foo@-  -> String              -- ^ The name of the executable to in the private bin-                         --   dir, eg @foo-1.0@-  -> 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.-symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do-  ok <- targetOkToOverwrite (publicBindir </> publicName)-                            (privateBindir </> privateName)-  case ok of-    NotExists         ->           mkLink >> return True-    OkToOverwrite     -> rmLink >> mkLink >> return True-    NotOurFile ->-      case overwritePolicy of-        NeverOverwrite  ->                     return False-        AlwaysOverwrite -> rmLink >> mkLink >> return True-  where-    relativeBindir = makeRelative publicBindir privateBindir-    mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)-    rmLink = removeFile (publicBindir </> publicName)---- | Check a file path of a symlink that we would like to create to see if it--- is OK. For it to be OK to overwrite it must either not already exist yet or--- be a symlink to our target (in which case we can assume ownership).----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.-                    -> IO SymlinkStatus-targetOkToOverwrite symlink target = handleNotExist $ do-  isLink <- pathIsSymbolicLink symlink-  if not isLink-    then return NotOurFile-    else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink-            -- This partially relies on canonicalizePath handling symlinks-            if target == target'-              then return OkToOverwrite-              else return NotOurFile--  where-    handleNotExist action = catchIO action $ \ioexception ->-      -- If the target doesn't exist then there's no problem overwriting it!-      if isDoesNotExistError ioexception-        then return NotExists-        else ioError ioexception--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 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).-  deriving Show---- | Take two canonical paths and produce a relative path to get from the first--- to the second, even if it means adding @..@ path components.----makeRelative :: FilePath -> FilePath -> FilePath-makeRelative a b = assert (isAbsolute a && isAbsolute b) $-  let as = splitPath a-      bs = splitPath b-      commonLen = length $ takeWhile id $ zipWith (==) as bs-   in joinPath $ [ ".." | _  <- drop commonLen as ]-              ++ drop commonLen bs---- | Try to make a symlink in a temporary directory.------ If this works, we can try to symlink: even on Windows.----trySymlink :: Verbosity -> IO Bool-trySymlink verbosity = do-  tmp <- getTemporaryDirectory-  withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do-    let from = tmpDirPath </> "file.txt"-    let to   = tmpDirPath </> "file2.txt"--    -- create a file-    BS.writeFile from (BS8.pack "TEST")--    -- create a symbolic link-    let create :: IO Bool-        create = do-          createFileLink from to-          info verbosity $ "Symlinking seems to work"-          return True--    create `catchIO` \exc -> do-      info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc-      return False
− Distribution/Client/JobControl.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.JobControl--- Copyright   :  (c) Duncan Coutts 2012--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ A job control concurrency abstraction-------------------------------------------------------------------------------module Distribution.Client.JobControl (-    JobControl,-    newSerialJobControl,-    newParallelJobControl,-    spawnJob,-    collectJob,-    remainingJobs,-    cancelJobs,--    JobLimit,-    newJobLimit,-    withJobLimit,--    Lock,-    newLock,-    criticalSection-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Control.Monad (forever, replicateM_)-import Control.Concurrent (forkIO)-import Control.Concurrent.MVar-import Control.Concurrent.STM (STM, atomically)-import Control.Concurrent.STM.TVar-import Control.Concurrent.STM.TChan-import Control.Exception (bracket_, try)-import Distribution.Compat.Stack-import Distribution.Client.Compat.Semaphore----- | A simple concurrency abstraction. Jobs can be spawned and can complete--- in any order. This allows both serial and parallel implementations.----data JobControl m a = JobControl {-       -- | Add a new job to the pool of jobs-       spawnJob    :: m a -> m (),--       -- | Wait until one job is complete-       collectJob  :: m a,--       -- | Returns True if there are any outstanding jobs-       -- (ie spawned but yet to be collected)-       remainingJobs :: m Bool,--       -- | Try to cancel any outstanding but not-yet-started jobs.-       -- Call 'remainingJobs' after this to find out if any jobs are left-       -- (ie could not be cancelled).-       cancelJobs  :: m ()-     }----- | Make a 'JobControl' that executes all jobs serially and in order.--- It only executes jobs on demand when they are collected, not eagerly.------ Cancelling will cancel /all/ jobs that have not been collected yet.----newSerialJobControl :: IO (JobControl IO a)-newSerialJobControl = do-    qVar <- newTChanIO-    return JobControl {-      spawnJob      = spawn     qVar,-      collectJob    = collect   qVar,-      remainingJobs = remaining qVar,-      cancelJobs    = cancel    qVar-    }-  where-    spawn :: TChan (IO a) -> IO a -> IO ()-    spawn qVar job = atomically $ writeTChan qVar job--    collect :: TChan (IO a) -> IO a-    collect qVar =-      join $ atomically $ readTChan qVar--    remaining :: TChan (IO a) -> IO Bool-    remaining qVar  = fmap not $ atomically $ isEmptyTChan qVar--    cancel :: TChan (IO a) -> IO ()-    cancel qVar = do-      _ <- atomically $ readAllTChan qVar-      return ()---- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given--- maximum degree of parallelism.------ Cancelling will cancel jobs that have not yet begun executing, but jobs--- that have already been executed or are currently executing cannot be--- cancelled.----newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a))-newParallelJobControl n | n < 1 || n > 1000 =-  error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n-newParallelJobControl maxJobLimit = do-    inqVar   <- newTChanIO-    outqVar  <- newTChanIO-    countVar <- newTVarIO 0-    replicateM_ maxJobLimit $-      forkIO $-        worker inqVar outqVar-    return JobControl {-      spawnJob      = spawn   inqVar  countVar,-      collectJob    = collect outqVar countVar,-      remainingJobs = remaining       countVar,-      cancelJobs    = cancel  inqVar  countVar-    }-  where-    worker ::  TChan (IO a) -> TChan (Either SomeException a) -> IO ()-    worker inqVar outqVar =-      forever $ do-        job <- atomically $ readTChan inqVar-        res <- try job-        atomically $ writeTChan outqVar res--    spawn :: TChan (IO a) -> TVar Int -> IO a -> IO ()-    spawn inqVar countVar job =-      atomically $ do-        modifyTVar' countVar (+1)-        writeTChan inqVar job--    collect :: TChan (Either SomeException a) -> TVar Int -> IO a-    collect outqVar countVar = do-      res <- atomically $ do-        modifyTVar' countVar (subtract 1)-        readTChan outqVar-      either throwIO return res--    remaining :: TVar Int -> IO Bool-    remaining countVar = fmap (/=0) $ atomically $ readTVar countVar--    cancel :: TChan (IO a) -> TVar Int -> IO ()-    cancel inqVar countVar =-      atomically $ do-        xs <- readAllTChan inqVar-        modifyTVar' countVar (subtract (length xs))--readAllTChan :: TChan a -> STM [a]-readAllTChan qvar = go []-  where-    go xs = do-      mx <- tryReadTChan qvar-      case mx of-        Nothing -> return (reverse xs)-        Just x  -> go (x:xs)------------------------------ Job limits and locks-----data JobLimit = JobLimit QSem--newJobLimit :: Int -> IO JobLimit-newJobLimit n =-  fmap JobLimit (newQSem n)--withJobLimit :: JobLimit -> IO a -> IO a-withJobLimit (JobLimit sem) =-  bracket_ (waitQSem sem) (signalQSem sem)--newtype Lock = Lock (MVar ())--newLock :: IO Lock-newLock = fmap Lock $ newMVar ()--criticalSection :: Lock -> IO a -> IO a-criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
− Distribution/Client/List.hs 
@@ -1,629 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.List--- Copyright   :  (c) David Himmelstrup 2005---                    Duncan Coutts 2008-2011--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org------ Search for and print information about packages-------------------------------------------------------------------------------module Distribution.Client.List (-  list, info-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Package-         ( PackageName, Package(..), packageName-         , packageVersion, UnitId )-import Distribution.Types.Dependency-import Distribution.Types.UnqualComponentName-import Distribution.ModuleName (ModuleName)-import Distribution.License (License)-import qualified Distribution.InstalledPackageInfo as Installed-import qualified Distribution.PackageDescription   as Source-import qualified Distribution.Types.ModuleReexport as Source-import Distribution.PackageDescription-         ( PackageFlag(..), unFlagName )-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )--import Distribution.Simple.Compiler-        ( Compiler, PackageDBStack )-import Distribution.Simple.Program (ProgramDb)-import Distribution.Simple.Utils-        ( equating, die', notice )-import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault)-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import Distribution.Version-         ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion-         , intersectVersionRanges, simplifyVersionRange )--import qualified Distribution.SPDX as SPDX--import           Distribution.Solver.Types.PackageConstraint-import qualified Distribution.Solver.Types.PackageIndex as PackageIndex-import           Distribution.Solver.Types.SourcePackage--import Distribution.Client.Types-         ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage )-import Distribution.Client.Targets-         ( UserTarget, resolveUserTargets )-import Distribution.Client.Setup-         ( GlobalFlags(..), ListFlags(..), InfoFlags(..)-         , RepoContext(..) )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )-import Distribution.Client.IndexUtils as IndexUtils-         ( getSourcePackages, getInstalledPackages )-import Distribution.Client.FetchUtils-         ( isFetched )--import Data.Bits ((.|.))-import Data.List-         ( maximumBy )-import Data.List.NonEmpty (groupBy, nonEmpty)-import qualified Data.List as L-import Data.Maybe-         ( fromJust )-import qualified Data.Map as Map-import Data.Tree as Tree-import Control.Exception-         ( assert )-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint-         ( lineLength, ribbonsPerLine, Doc, renderStyle, char-         , nest, ($+$), text, vcat, style, parens, fsep)-import System.Directory-         ( doesDirectoryExist )--import Distribution.Utils.ShortText (ShortText)-import qualified Distribution.Utils.ShortText as ShortText-import qualified Text.Regex.Base as Regex-import qualified Text.Regex.Posix.String as Regex----- | Return a list of packages matching given search strings.-getPkgList :: Verbosity-           -> PackageDBStack-           -> RepoContext-           -> Maybe (Compiler, ProgramDb)-           -> ListFlags-           -> [String]-           -> IO [PackageDisplayInfo]-getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do-    installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->-        getInstalledPackages verbosity comp packageDBs progdb-    sourcePkgDb       <- getSourcePackages verbosity repoCtxt--    regexps <- for pats $ \pat -> do-        e <- Regex.compile compOption Regex.execBlank pat-        case e of-            Right r  -> return r-            Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err--    let sourcePkgIndex = packageIndex sourcePkgDb-        prefs name = fromMaybe anyVersion-                       (Map.lookup name (packagePreferences sourcePkgDb))--        pkgsInfoMatching ::-          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]-        pkgsInfoMatching =-          let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex-              matchingSource    = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex-          in mergePackages matchingInstalled matchingSource--        pkgsInfo ::-          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]-        pkgsInfo-            -- gather info for all packages-          | null regexps = mergePackages-                           (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)-                           (         PackageIndex.allPackages          sourcePkgIndex)--            -- gather info for packages matching search term-          | otherwise = pkgsInfoMatching--        matches :: [PackageDisplayInfo]-        matches = [ mergePackageInfo pref-                      installedPkgs sourcePkgs selectedPkg False-                  | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo-                  , not onlyInstalled || not (null installedPkgs)-                  , let pref        = prefs pkgname-                        selectedPkg = latestWithPref pref sourcePkgs ]-    return matches-  where-    onlyInstalled   = fromFlagOrDefault False (listInstalled listFlags)-    caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags)--    compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase-               | otherwise       = Regex.compExtended--    matchingPackages search regexps index =-      [ pkg-      | re <- regexps-      , pkg <- search index (Regex.matchTest re) ]----- | Show information about packages.-list :: Verbosity-     -> PackageDBStack-     -> RepoContext-     -> Maybe (Compiler, ProgramDb)-     -> ListFlags-     -> [String]-     -> IO ()-list verbosity packageDBs repos mcompProgdb listFlags pats = do-    matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats--    if simpleOutput-      then putStr $ unlines-             [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version-             | pkg <- matches-             , version <- if onlyInstalled-                            then              installedVersions pkg-                            else nub . sort $ installedVersions pkg-                                           ++ sourceVersions    pkg ]-             -- Note: this only works because for 'list', one cannot currently-             -- specify any version constraints, so listing all installed-             -- and source ones works.-      else-        if null matches-            then notice verbosity "No matches found."-            else putStr $ unlines (map showPackageSummaryInfo matches)-  where-    onlyInstalled = fromFlag (listInstalled listFlags)-    simpleOutput  = fromFlag (listSimpleOutput listFlags)--info :: Verbosity-     -> PackageDBStack-     -> RepoContext-     -> Compiler-     -> ProgramDb-     -> GlobalFlags-     -> InfoFlags-     -> [UserTarget]-     -> IO ()-info verbosity _ _ _ _ _ _ [] =-    notice verbosity "No packages requested. Nothing to do."--info verbosity packageDBs repoCtxt comp progdb-     globalFlags _listFlags userTargets = do--    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb-    sourcePkgDb       <- getSourcePackages verbosity repoCtxt-    let sourcePkgIndex = packageIndex sourcePkgDb-        prefs name = fromMaybe anyVersion-                       (Map.lookup name (packagePreferences sourcePkgDb))--        -- Users may specify names of packages that are only installed, not-        -- just available source packages, so we must resolve targets using-        -- the combination of installed and source packages.-    let sourcePkgs' = PackageIndex.fromList-                    $ map packageId-                      (InstalledPackageIndex.allPackages installedPkgIndex)-                   ++ map packageId-                      (PackageIndex.allPackages sourcePkgIndex)-    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt-                       (fromFlag $ globalWorldFile globalFlags)-                       sourcePkgs' userTargets--    pkgsinfo      <- sequenceA-                       [ do pkginfo <- either (die' verbosity) return $-                                         gatherPkgInfo prefs-                                           installedPkgIndex sourcePkgIndex-                                           pkgSpecifier-                            updateFileSystemPackageDetails pkginfo-                       | pkgSpecifier <- pkgSpecifiers ]--    putStr $ unlines (map showPackageDetailedInfo pkgsinfo)--  where-    gatherPkgInfo :: (PackageName -> VersionRange) ->-                     InstalledPackageIndex ->-                     PackageIndex.PackageIndex UnresolvedSourcePackage ->-                     PackageSpecifier UnresolvedSourcePackage ->-                     Either String PackageDisplayInfo-    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex-      (NamedPackage name props)-      | null (selectedInstalledPkgs) && null (selectedSourcePkgs)-      = Left $ "There is no available version of " ++ prettyShow name-            ++ " that satisfies "-            ++ prettyShow (simplifyVersionRange verConstraint)--      | otherwise-      = Right $ mergePackageInfo pref installedPkgs-                                 sourcePkgs  selectedSourcePkg'-                                 showPkgVersion-      where-        (pref, installedPkgs, sourcePkgs) =-          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex--        selectedInstalledPkgs = InstalledPackageIndex.lookupDependency-                                installedPkgIndex-                                name verConstraint-        selectedSourcePkgs    = PackageIndex.lookupDependency sourcePkgIndex-                                name verConstraint-        selectedSourcePkg'    = latestWithPref pref selectedSourcePkgs--                         -- display a specific package version if the user-                         -- supplied a non-trivial version constraint-        showPkgVersion = not (null verConstraints)-        verConstraint  = foldr intersectVersionRanges anyVersion verConstraints-        verConstraints = [ vr | PackagePropertyVersion vr <- props ]--    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex-      (SpecificSourcePackage pkg) =-        Right $ mergePackageInfo pref installedPkgs sourcePkgs-                                 selectedPkg True-      where-        name          = packageName pkg-        selectedPkg   = Just pkg-        (pref, installedPkgs, sourcePkgs) =-          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex--sourcePkgsInfo ::-  (PackageName -> VersionRange)-  -> PackageName-  -> InstalledPackageIndex-  -> PackageIndex.PackageIndex UnresolvedSourcePackage-  -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])-sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =-  (pref, installedPkgs, sourcePkgs)-  where-    pref          = prefs name-    installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName-                                   installedPkgIndex name)-    sourcePkgs    = PackageIndex.lookupPackageName sourcePkgIndex name----- | The info that we can display for each package. It is information per--- package name and covers all installed and available versions.----data PackageDisplayInfo = PackageDisplayInfo {-    pkgName           :: PackageName,-    selectedVersion   :: Maybe Version,-    selectedSourcePkg :: Maybe UnresolvedSourcePackage,-    installedVersions :: [Version],-    sourceVersions    :: [Version],-    preferredVersions :: VersionRange,-    homepage          :: ShortText,-    bugReports        :: ShortText,-    sourceRepo        :: String, -- TODO-    synopsis          :: ShortText,-    description       :: ShortText,-    category          :: ShortText,-    license           :: Either SPDX.License License,-    author            :: ShortText,-    maintainer        :: ShortText,-    dependencies      :: [ExtDependency],-    flags             :: [PackageFlag],-    hasLib            :: Bool,-    hasExe            :: Bool,-    executables       :: [UnqualComponentName],-    modules           :: [ModuleName],-    haddockHtml       :: FilePath,-    haveTarball       :: Bool-  }---- | Covers source dependencies and installed dependencies in--- one type.-data ExtDependency = SourceDependency Dependency-                   | InstalledDependency UnitId--showPackageSummaryInfo :: PackageDisplayInfo -> String-showPackageSummaryInfo pkginfo =-  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-     char '*' <+> pretty (pkgName pkginfo)-     $+$-     (nest 4 $ vcat [-       maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs-     , text "Default available version:" <+>-       case selectedSourcePkg pkginfo of-         Nothing  -> text "[ Not available from any configured repository ]"-         Just pkg -> pretty (packageVersion pkg)-     , text "Installed versions:" <+>-       case installedVersions pkginfo of-         []  | hasLib pkginfo -> text "[ Not installed ]"-             | otherwise      -> text "[ Unknown ]"-         versions             -> dispTopVersions 4-                                   (preferredVersions pkginfo) versions-     , maybeShowST (homepage pkginfo) "Homepage:" text-     , text "License: " <+> either pretty pretty (license pkginfo)-     ])-     $+$ text ""-  where-    maybeShowST l s f-        | ShortText.null l = Disp.empty-        | otherwise        = text s <+> f (ShortText.fromShortText l)--showPackageDetailedInfo :: PackageDisplayInfo -> String-showPackageDetailedInfo pkginfo =-  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-   char '*' <+> pretty (pkgName pkginfo)-            <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)-            <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')-            <<>> parens pkgkind-   $+$-   (nest 4 $ vcat [-     entryST "Synopsis"      synopsis     hideIfNull  reflowParagraphs-   , entry "Versions available" sourceVersions-           (altText null "[ Not available from server ]")-           (dispTopVersions 9 (preferredVersions pkginfo))-   , entry "Versions installed" installedVersions-           (altText null (if hasLib pkginfo then "[ Not installed ]"-                                            else "[ Unknown ]"))-           (dispTopVersions 4 (preferredVersions pkginfo))-   , entryST "Homepage"      homepage     orNotSpecified text-   , entryST "Bug reports"   bugReports   orNotSpecified text-   , entryST "Description"   description  hideIfNull     reflowParagraphs-   , entryST "Category"      category     hideIfNull     text-   , entry "License"       license      alwaysShow     (either pretty pretty)-   , entryST "Author"        author       hideIfNull     reflowLines-   , entryST "Maintainer"    maintainer   hideIfNull     reflowLines-   , entry "Source repo"   sourceRepo   orNotSpecified text-   , entry "Executables"   executables  hideIfNull     (commaSep pretty)-   , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)-   , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)-   , entry "Documentation" haddockHtml  showIfInstalled text-   , entry "Cached"        haveTarball  alwaysShow     dispYesNo-   , if not (hasLib pkginfo) then mempty else-     text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))-   ])-   $+$ text ""-  where-    entry fname field cond format = case cond (field pkginfo) of-      Nothing           -> label <+> format (field pkginfo)-      Just Nothing      -> mempty-      Just (Just other) -> label <+> text other-      where-        label   = text fname Disp.<> char ':' Disp.<> padding-        padding = text (replicate (13 - length fname ) ' ')--    entryST fname field = entry fname (ShortText.fromShortText . field)--    normal      = Nothing-    hide        = Just Nothing-    replace msg = Just (Just msg)--    alwaysShow = const normal-    hideIfNull v = if null v then hide else normal-    showIfInstalled v-      | not isInstalled = hide-      | null v          = replace "[ Not installed ]"-      | otherwise       = normal-    altText nul msg v = if nul v then replace msg else normal-    orNotSpecified = altText null "[ Not specified ]"--    commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f-    dispFlag = text . unFlagName . flagName-    dispYesNo True  = text "Yes"-    dispYesNo False = text "No"--    dispExtDep (SourceDependency    dep) = pretty dep-    dispExtDep (InstalledDependency dep) = pretty dep--    isInstalled = not (null (installedVersions pkginfo))-    hasExes = length (executables pkginfo) >= 2-    --TODO: exclude non-buildable exes-    pkgkind | hasLib pkginfo && hasExes        = text "programs and library"-            | hasLib pkginfo && hasExe pkginfo = text "program and library"-            | hasLib pkginfo                   = text "library"-            | hasExes                          = text "programs"-            | hasExe pkginfo                   = text "program"-            | otherwise                        = mempty---reflowParagraphs :: String -> Doc-reflowParagraphs =-    vcat-  . intersperse (text "")                    -- re-insert blank lines-  . map (fsep . map text . concatMap words)  -- reflow paragraphs-  . filter (/= [""])-  . L.groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines-  . lines--reflowLines :: String -> Doc-reflowLines = vcat . map text . lines---- | We get the 'PackageDisplayInfo' by combining the info for the installed--- and available versions of a package.------ * We're building info about a various versions of a single named package so--- the input package info records are all supposed to refer to the same--- package name.----mergePackageInfo :: VersionRange-                 -> [Installed.InstalledPackageInfo]-                 -> [UnresolvedSourcePackage]-                 -> Maybe UnresolvedSourcePackage-                 -> Bool-                 -> PackageDisplayInfo-mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =-  assert (length installedPkgs + length sourcePkgs > 0) $-  PackageDisplayInfo {-    pkgName           = combine packageName source-                                packageName installed,-    selectedVersion   = if showVer then fmap packageVersion selectedPkg-                                   else Nothing,-    selectedSourcePkg = sourceSelected,-    installedVersions = map packageVersion installedPkgs,-    sourceVersions    = map packageVersion sourcePkgs,-    preferredVersions = versionPref,--    license      = combine Source.licenseRaw    source-                           Installed.license    installed,-    maintainer   = combine Source.maintainer    source-                           Installed.maintainer installed,-    author       = combine Source.author        source-                           Installed.author     installed,-    homepage     = combine Source.homepage      source-                           Installed.homepage   installed,-    bugReports   = maybe mempty Source.bugReports source,-    sourceRepo   = fromMaybe mempty . join-                 . fmap (uncons Nothing Source.repoLocation-                       . sortBy (comparing Source.repoKind)-                       . Source.sourceRepos)-                 $ source,-                    --TODO: installed package info is missing synopsis-    synopsis     = maybe mempty Source.synopsis      source,-    description  = combine Source.description    source-                           Installed.description installed,-    category     = combine Source.category       source-                           Installed.category    installed,-    flags        = maybe [] Source.genPackageFlags sourceGeneric,-    hasLib       = isJust installed-                || maybe False (isJust . Source.condLibrary) sourceGeneric,-    hasExe       = maybe False (not . null . Source.condExecutables) sourceGeneric,-    executables  = map fst (maybe [] Source.condExecutables sourceGeneric),-    modules      = combine (map Installed.exposedName . Installed.exposedModules)-                           installed-                           -- NB: only for the PUBLIC library-                           (concatMap getListOfExposedModules . maybeToList . Source.library)-                           source,-    dependencies =-      combine (map (SourceDependency . simplifyDependency)-               . Source.allBuildDepends) source-      (map InstalledDependency . Installed.depends) installed,-    haddockHtml  = fromMaybe "" . join-                 . fmap (listToMaybe . Installed.haddockHTMLs)-                 $ installed,-    haveTarball  = False-  }-  where-    combine f x g y  = fromJust (fmap f x `mplus` fmap g y)-    installed :: Maybe Installed.InstalledPackageInfo-    installed = latestWithPref versionPref installedPkgs--    getListOfExposedModules lib = Source.exposedModules lib-                               ++ map Source.moduleReexportName-                                      (Source.reexportedModules lib)--    sourceSelected-      | isJust selectedPkg = selectedPkg-      | otherwise          = latestWithPref versionPref sourcePkgs-    sourceGeneric = fmap srcpkgDescription sourceSelected-    source        = fmap flattenPackageDescription sourceGeneric--    uncons :: b -> (a -> b) -> [a] -> b-    uncons z _ []    = z-    uncons _ f (x:_) = f x----- | Not all the info is pure. We have to check if the docs really are--- installed, because the registered package info lies. Similarly we have to--- check if the tarball has indeed been fetched.----updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo-updateFileSystemPackageDetails pkginfo = do-  fetched   <- maybe (return False) (isFetched . srcpkgSource)-                     (selectedSourcePkg pkginfo)-  docsExist <- doesDirectoryExist (haddockHtml pkginfo)-  return pkginfo {-    haveTarball = fetched,-    haddockHtml = if docsExist then haddockHtml pkginfo else ""-  }--latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg-latestWithPref _    []   = Nothing-latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)-  where-    prefThenVersion pkg = let ver = packageVersion pkg-                           in (withinRange ver pref, ver)----- | Rearrange installed and source packages into groups referring to the--- same package by name. In the result pairs, the lists are guaranteed to not--- both be empty.----mergePackages :: [Installed.InstalledPackageInfo]-              -> [UnresolvedSourcePackage]-              -> [( PackageName-                  , [Installed.InstalledPackageInfo]-                  , [UnresolvedSourcePackage] )]-mergePackages installedPkgs sourcePkgs =-    map collect-  $ mergeBy (\i a -> fst i `compare` fst a)-            (groupOn packageName installedPkgs)-            (groupOn packageName sourcePkgs)-  where-    collect (OnlyInLeft  (name,is)         ) = (name, is, [])-    collect (    InBoth  (_,is)   (name,as)) = (name, is, as)-    collect (OnlyInRight          (name,as)) = (name, [], as)--groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]-groupOn key = map (\xs -> (key (head xs), toList xs))-            . groupBy (equating key)-            . sortBy (comparing key)--dispTopVersions :: Int -> VersionRange -> [Version] -> Doc-dispTopVersions n pref vs =-         (Disp.fsep . Disp.punctuate (Disp.char ',')-        . map (\ver -> if ispref ver then pretty ver else parens (pretty ver))-        . sort . take n . interestingVersions ispref-        $ vs)-    <+> trailingMessage--  where-    ispref ver = withinRange ver pref-    extra = length vs - n-    trailingMessage-      | extra <= 0 = Disp.empty-      | otherwise  = Disp.parens $ Disp.text "and"-                               <+> Disp.int (length vs - n)-                               <+> if extra == 1 then Disp.text "other"-                                                 else Disp.text "others"---- | Reorder a bunch of versions to put the most interesting / significant--- versions first. A preferred version range is taken into account.------ This may be used in a user interface to select a small number of versions--- to present to the user, e.g.------ > let selectVersions = sort . take 5 . interestingVersions pref----interestingVersions :: (Version -> Bool) -> [Version] -> [Version]-interestingVersions pref =-      map (mkVersion . fst) . filter snd-    . concat  . Tree.levels-    . swizzleTree-    . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))-    . reverseTree-    . mkTree-    . map (or0 . versionNumbers)--  where-    or0 []     = 0 :| []-    or0 (x:xs) = x :| xs--    swizzleTree = unfoldTree (spine [])-      where-        spine ts' (Node x [])     = (x, ts')-        spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t--    reorderTree _ (Node x []) = Node x []-    reorderTree p (Node x ts) = Node x (ts' ++ ts'')-      where-        (ts',ts'') = partition p (map (reorderTree p) ts)--    reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))--    mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool)-    mkTree xs = unfoldTree step (False, [], xs)-      where-        step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])-        step (node,ns,vs) =-          ( (reverse ns, node)-          , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs'))-            | (n, vs') <- groups vs-            ]-          )--        groups :: [NonEmpty a] -> [(a, NonEmpty [a])]-        groups = map (\g -> (head (head g), fmap tail g))-               . groupBy (equating head)
− Distribution/Client/Manpage.hs 
@@ -1,212 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Manpage--- Copyright   :  (c) Maciek Makowski 2015--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Functions for building the manual page.--module Distribution.Client.Manpage-  ( -- * Manual page generation-    manpage-  , manpageCmd-  , ManpageFlags-  , defaultManpageFlags-  , manpageOptions-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.ManpageFlags-import Distribution.Client.Setup        (globalCommand)-import Distribution.Compat.Process      (createProcess)-import Distribution.Simple.Command-import Distribution.Simple.Flag         (fromFlagOrDefault)-import System.IO                        (hClose, hPutStr)--import qualified System.Process as Process--data FileInfo = FileInfo String String -- ^ path, description------------------------------------------------------------------------------------------------------------------------------------------------------------------------ | A list of files that should be documented in the manual page.-files :: [FileInfo]-files =-  [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")-  , (FileInfo "~/.cabal/world"  "A list of all packages whose installation has been explicitly requested.")-  ]--manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()-manpageCmd pname commands flags-    | fromFlagOrDefault False (manpageRaw flags)-    = putStrLn contents-    | otherwise-    = do-        let cmd  = "man"-            args = ["-l", "-"]--        (mb_in, _, _, ph) <- createProcess (Process.proc cmd args)-            { Process.std_in  = Process.CreatePipe-            , Process.std_out = Process.Inherit-            , Process.std_err = Process.Inherit-            }--        -- put contents-        for_ mb_in $ \hin -> do-            hPutStr hin contents-            hClose hin--        -- wait for process to exit, propagate exit code-        ec <- Process.waitForProcess ph-        exitWith ec-  where-    contents :: String-    contents = manpage pname commands---- | Produces a manual page with @troff@ markup.-manpage :: String -> [CommandSpec a] -> String-manpage pname commands = unlines $-  [ ".TH " ++ map toUpper pname ++ " 1"-  , ".SH NAME"-  , pname ++ " \\- a system for building and packaging Haskell libraries and programs"-  , ".SH SYNOPSIS"-  , ".B " ++ pname-  , ".I command"-  , ".RI < arguments |[ options ]>..."-  , ""-  , "Where the"-  , ".I commands"-  , "are"-  , ""-  ] ++-  concatMap (commandSynopsisLines pname) commands ++-  [ ".SH DESCRIPTION"-  , "Cabal is the standard package system for Haskell software. It helps people to configure, "-  , "build and install Haskell software and to distribute it easily to other users and developers."-  , ""-  , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "-  , "installing existing packages and developing new packages. "-  , "It can be used to work with local packages or to install packages from online package archives, "-  , "including automatically installing dependencies. By default it is configured to use Hackage, "-  , "which is Haskell's central package archive that contains thousands of libraries and applications "-  , "in the Cabal package format."-  , ".SH OPTIONS"-  , "Global options:"-  , ""-  ] ++-  optionsLines (globalCommand []) ++-  [ ".SH COMMANDS"-  ] ++-  concatMap (commandDetailsLines pname) commands ++-  [ ".SH FILES"-  ] ++-  concatMap fileLines files ++-  [ ".SH BUGS"-  , "To browse the list of known issues or report a new one please see "-  , "https://github.com/haskell/cabal/labels/cabal-install."-  ]--commandSynopsisLines :: String -> CommandSpec action -> [String]-commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =-  [ ".B " ++ pname ++ " " ++ (commandName ui)-  , ".R - " ++ commandSynopsis ui-  , ".br"-  ]-commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []--commandDetailsLines :: String -> CommandSpec action -> [String]-commandDetailsLines pname (CommandSpec ui _ NormalCommand) =-  [ ".B " ++ pname ++ " " ++ (commandName ui)-  , ""-  , commandUsage ui pname-  , ""-  ] ++-  optional commandDescription ++-  optional commandNotes ++-  [ "Flags:"-  , ".RS"-  ] ++-  optionsLines ui ++-  [ ".RE"-  , ""-  ]-  where-    optional field =-      case field ui of-        Just text -> [text pname, ""]-        Nothing   -> []-commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []--optionsLines :: CommandUI flags -> [String]-optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs))--data ArgumentRequired = Optional | Required-type OptionArg = (ArgumentRequired, ArgPlaceHolder)--optionLines :: OptDescr flags -> [String]-optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =-  argOptionLines description optionChars optionStrings (Required, placeHolder)-optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =-  argOptionLines description optionChars optionStrings (Optional, placeHolder)-optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =-  optionLinesIfPresent trueChars trueStrings ++-  optionLinesIfPresent falseChars falseStrings ++-  optionDescriptionLines description-optionLines (ChoiceOpt options) =-  concatMap choiceLines options-  where-    choiceLines (description, (optionChars, optionStrings), _, _) =-      [ optionsLine optionChars optionStrings ] ++-      optionDescriptionLines description--argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]-argOptionLines description optionChars optionStrings arg =-  [ optionsLine optionChars optionStrings-  , optionArgLine arg-  ] ++-  optionDescriptionLines description--optionLinesIfPresent :: [Char] -> [String] -> [String]-optionLinesIfPresent optionChars optionStrings =-  if null optionChars && null optionStrings then []-  else                                           [ optionsLine optionChars optionStrings, ".br" ]--optionDescriptionLines :: String -> [String]-optionDescriptionLines description =-  [ ".RS"-  , description-  , ".RE"-  , ""-  ]--optionsLine :: [Char] -> [String] -> String-optionsLine optionChars optionStrings =-  intercalate ", " (shortOptions optionChars ++ longOptions optionStrings)--shortOptions :: [Char] -> [String]-shortOptions = map (\c -> "\\-" ++ [c])--longOptions :: [String] -> [String]-longOptions = map (\s -> "\\-\\-" ++ s)--optionArgLine :: OptionArg -> String-optionArgLine (Required, placeHolder) = ".I " ++ placeHolder-optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]"--fileLines :: FileInfo -> [String]-fileLines (FileInfo path description) =-  [ path-  , ".RS"-  , description-  , ".RE"-  , ""-  ]
− Distribution/Client/ManpageFlags.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase    #-}-module Distribution.Client.ManpageFlags-( ManpageFlags (..)-, defaultManpageFlags-, manpageOptions,-) where--import Distribution.Client.Compat.Prelude--import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)-import Distribution.Simple.Setup   (Flag (..), toFlag, trueArg, optionVerbosity)-import Distribution.Verbosity      (normal)--data ManpageFlags = ManpageFlags-  { manpageVerbosity :: Flag Verbosity-  , manpageRaw       :: Flag Bool-  } deriving (Eq, Show, Generic)--instance Monoid ManpageFlags  where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ManpageFlags where-  (<>) = gmappend--defaultManpageFlags :: ManpageFlags-defaultManpageFlags = ManpageFlags-    { manpageVerbosity = toFlag normal-    , manpageRaw       = toFlag False-    }--manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags]-manpageOptions _ =-    [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v })-    , option "" ["raw"]-      "Output raw troff content"-      manpageRaw (\v flags -> flags { manpageRaw = v })-      trueArg-    ]
− Distribution/Client/Nix.hs 
@@ -1,182 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}--module Distribution.Client.Nix-       ( findNixExpr-       , inNixShell-       , nixInstantiate-       , nixShell-       ) where--import Distribution.Client.Compat.Prelude--import Control.Exception (bracket)-import System.Directory-       ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist-       , doesFileExist, removeDirectoryRecursive, removeFile )-import System.Environment (getArgs, getExecutablePath)-import System.FilePath-       ( (</>), replaceExtension, takeDirectory, takeFileName )-import System.IO (IOMode(..), hClose, openFile)-import System.IO.Error (isDoesNotExistError)-import System.Process (showCommandForUser)--import Distribution.Compat.Environment-       ( lookupEnv, setEnv, unsetEnv )--import Distribution.Simple.Program-       ( Program(..), ProgramDb-       , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput-       , runDbProgram, simpleProgram )-import Distribution.Simple.Setup (fromFlagOrDefault)-import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan)--import Distribution.Client.Config (SavedConfig(..))-import Distribution.Client.GlobalFlags (GlobalFlags(..))---configureOneProgram :: Verbosity -> Program -> IO ProgramDb-configureOneProgram verb prog =-  configureProgram verb prog (addKnownProgram prog emptyProgramDb)---touchFile :: FilePath -> IO ()-touchFile path = do-  catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ()))-  createDirectoryIfMissing True (takeDirectory path)-  openFile path WriteMode >>= hClose---findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath)-findNixExpr globalFlags config = do-  -- criteria for deciding to run nix-shell-  let nixEnabled =-        fromFlagOrDefault False-        (globalNix (savedGlobalFlags config) <> globalNix globalFlags)--  if nixEnabled-    then do-      let exprPaths = [ "shell.nix", "default.nix" ]-      filterM doesFileExist exprPaths >>= \case-        [] -> return Nothing-        (path : _) -> return (Just path)-    else return Nothing----- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell-inFakeNixShell :: IO a -> IO a-inFakeNixShell f =-  bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f)-  where-    fakeEnv var new = do-      old <- lookupEnv var-      setEnv var new-      return old-    resetEnv var = maybe (unsetEnv var) (setEnv var)---nixInstantiate-  :: Verbosity-  -> FilePath-  -> Bool-  -> GlobalFlags-  -> SavedConfig-  -> IO ()-nixInstantiate verb dist force' globalFlags config =-  findNixExpr globalFlags config >>= \case-    Nothing -> return ()-    Just shellNix -> do-      alreadyInShell <- inNixShell-      shellDrv <- drvPath dist shellNix-      instantiated <- doesFileExist shellDrv-      -- an extra timestamp file is necessary because the derivation lives in-      -- the store so its mtime is always 1.-      let timestamp = timestampPath dist shellNix-      upToDate <- existsAndIsMoreRecentThan timestamp shellNix--      let ready = alreadyInShell || (instantiated && upToDate && not force')-      unless ready $ do--        let prog = simpleProgram "nix-instantiate"-        progdb <- configureOneProgram verb prog--        removeGCRoots verb dist-        touchFile timestamp--        _ <- inFakeNixShell-             (getDbProgramOutput verb prog progdb-              [ "--add-root", shellDrv, "--indirect", shellNix ])-        return ()---nixShell-  :: Verbosity-  -> FilePath-  -> GlobalFlags-  -> SavedConfig-  -> IO ()-     -- ^ The action to perform inside a nix-shell. This is also the action-     -- that will be performed immediately if Nix is disabled.-  -> IO ()-nixShell verb dist globalFlags config go = do--  alreadyInShell <- inNixShell--  if alreadyInShell-    then go-    else do-      findNixExpr globalFlags config >>= \case-        Nothing -> go-        Just shellNix -> do--          let prog = simpleProgram "nix-shell"-          progdb <- configureOneProgram verb prog--          cabal <- getExecutablePath--          -- alreadyInShell == True in child process-          setEnv "CABAL_IN_NIX_SHELL" "1"--          -- Run cabal with the same arguments inside nix-shell.-          -- When the child process reaches the top of nixShell, it will-          -- detect that it is running inside the shell and fall back-          -- automatically.-          shellDrv <- drvPath dist shellNix-          args <- getArgs-          runDbProgram verb prog progdb-            [ "--add-root", gcrootPath dist </> "result", "--indirect", shellDrv-            , "--run", showCommandForUser cabal args-            ]---drvPath :: FilePath -> FilePath -> IO FilePath-drvPath dist path = do-  -- We do not actually care about canonicity, but makeAbsolute is only-  -- available in newer versions of directory.-  -- We expect the path to be a symlink if it exists, so we do not canonicalize-  -- the entire path because that would dereference the symlink.-  distNix <- canonicalizePath (dist </> "nix")-  -- Nix garbage collector roots must be absolute paths-  return (distNix </> replaceExtension (takeFileName path) "drv")---timestampPath :: FilePath -> FilePath -> FilePath-timestampPath dist path =-  dist </> "nix" </> replaceExtension (takeFileName path) "drv.timestamp"---gcrootPath :: FilePath -> FilePath-gcrootPath dist = dist </> "nix" </> "gcroots"---inNixShell :: IO Bool-inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL"---removeGCRoots :: Verbosity -> FilePath -> IO ()-removeGCRoots verb dist = do-  let tgt = gcrootPath dist-  exists <- doesDirectoryExist tgt-  when exists $ do-    debug verb ("removing Nix gcroots from " ++ tgt)-    removeDirectoryRecursive tgt
− Distribution/Client/NixStyleOptions.hs 
@@ -1,85 +0,0 @@--- | Command line options for nix-style / v2 commands.------ The commands take a lot of the same options, which affect how install plan--- is constructed.-module Distribution.Client.NixStyleOptions (-    NixStyleFlags (..),-    nixStyleOptions,-    defaultNixStyleFlags,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Simple.Command                       (OptionField (..), ShowOrParseArgs)-import Distribution.Simple.Setup                         (BenchmarkFlags, HaddockFlags, TestFlags)-import Distribution.Solver.Types.ConstraintSource        (ConstraintSource (..))--import Distribution.Client.ProjectFlags-       (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions)-import Distribution.Client.Setup-       (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions,-       configureOptions, haddockOptions, installOptions, liftOptions, testOptions)--data NixStyleFlags a = NixStyleFlags-    { configFlags    :: ConfigFlags-    , configExFlags  :: ConfigExFlags-    , installFlags   :: InstallFlags-    , haddockFlags   :: HaddockFlags-    , testFlags      :: TestFlags-    , benchmarkFlags :: BenchmarkFlags-    , projectFlags   :: ProjectFlags-    , extraFlags     :: a-    }--nixStyleOptions-    :: (ShowOrParseArgs -> [OptionField a])-    -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]-nixStyleOptions commandOptions showOrParseArgs =-        liftOptions configFlags     set1-        -- Note: [Hidden Flags]-        -- hide "constraint", "dependency", and-        -- "exact-configuration" from the configure options.-        (filter ((`notElem` ["constraint", "dependency"-                            , "exact-configuration"])-                 . optionName) $ configureOptions showOrParseArgs)-     ++ liftOptions configExFlags   set2 (configureExOptions showOrParseArgs-                               ConstraintSourceCommandlineFlag)-     ++ liftOptions installFlags   set3-        -- hide "target-package-db" and "symlink-bindir" flags from the-        -- install options.-        -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags-        (filter ((`notElem` ["target-package-db", "symlink-bindir"])-                 . optionName) $-                               installOptions showOrParseArgs)-       ++ liftOptions haddockFlags set4-          -- hide "verbose" and "builddir" flags from the-          -- haddock options.-          (filter ((`notElem` ["v", "verbose", "builddir"])-                  . optionName) $-                                haddockOptions showOrParseArgs)-     ++ liftOptions testFlags      set5 (testOptions showOrParseArgs)-     ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs)-     ++ liftOptions projectFlags   set7 (projectFlagsOptions showOrParseArgs)-     ++ liftOptions extraFlags     set8 (commandOptions showOrParseArgs)-  where-    set1 x flags = flags { configFlags    = x }-    set2 x flags = flags { configExFlags  = x }-    set3 x flags = flags { installFlags   = x }-    set4 x flags = flags { haddockFlags   = x }-    set5 x flags = flags { testFlags      = x }-    set6 x flags = flags { benchmarkFlags = x }-    set7 x flags = flags { projectFlags   = x }-    set8 x flags = flags { extraFlags     = x }--defaultNixStyleFlags :: a ->  NixStyleFlags a-defaultNixStyleFlags x = NixStyleFlags-    { configFlags    = mempty-    , configExFlags  = mempty-    , installFlags   = mempty-    , haddockFlags   = mempty-    , testFlags      = mempty-    , benchmarkFlags = mempty-    , projectFlags   = defaultProjectFlags-    , extraFlags     = x-    }
− Distribution/Client/Outdated.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Outdated--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Implementation of the 'outdated' command. Checks for outdated--- dependencies in the package description file or freeze file.--------------------------------------------------------------------------------module Distribution.Client.Outdated ( outdated-                                    , ListOutdatedSettings(..), listOutdated )-where--import Prelude ()-import Distribution.Client.Config-import Distribution.Client.IndexUtils as IndexUtils-import Distribution.Client.Compat.Prelude-import Distribution.Client.ProjectConfig-import Distribution.Client.DistDirLayout-import Distribution.Client.RebuildMonad-import Distribution.Client.Setup hiding (quiet)-import Distribution.Client.Targets-import Distribution.Client.Types-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackageIndex-import Distribution.Client.Sandbox.PackageEnvironment-import Distribution.Utils.Generic--import Distribution.Package                          (PackageName, packageVersion)-import Distribution.PackageDescription               (allBuildDepends)-import Distribution.PackageDescription.Configuration (finalizePD)-import Distribution.Simple.Compiler                  (Compiler, compilerInfo)-import Distribution.Simple.Setup-       (fromFlagOrDefault, flagToMaybe)-import Distribution.Simple.Utils-       (die', notice, debug, tryFindPackageDesc)-import Distribution.System                           (Platform)-import Distribution.Types.ComponentRequestedSpec-       (ComponentRequestedSpec(..))-import Distribution.Types.Dependency-       (Dependency(..))-import Distribution.Verbosity                        (silent)-import Distribution.Version-       (Version, VersionRange, LowerBound(..), UpperBound(..)-       ,asVersionIntervals, majorBoundVersion)-import Distribution.PackageDescription.Parsec-       (readGenericPackageDescription)-import Distribution.Types.PackageVersionConstraint-       (PackageVersionConstraint (..), simplifyPackageVersionConstraint)--import qualified Data.Set as S-import System.Directory                              (getCurrentDirectory)---- | Entry point for the 'outdated' command.-outdated :: Verbosity -> OutdatedFlags -> RepoContext-         -> Compiler -> Platform-         -> IO ()-outdated verbosity0 outdatedFlags repoContext comp platform = do-  let freezeFile    = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags)-      newFreezeFile = fromFlagOrDefault False-                      (outdatedNewFreezeFile outdatedFlags)-      mprojectFile  = flagToMaybe-                      (outdatedProjectFile outdatedFlags)-      simpleOutput  = fromFlagOrDefault False-                      (outdatedSimpleOutput outdatedFlags)-      quiet         = fromFlagOrDefault False (outdatedQuiet outdatedFlags)-      exitCode      = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags)-      ignorePred    = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags)-                      in \pkgname -> pkgname `S.member` ignoreSet-      minorPred     = case outdatedMinor outdatedFlags of-                        Nothing -> const False-                        Just IgnoreMajorVersionBumpsNone -> const False-                        Just IgnoreMajorVersionBumpsAll  -> const True-                        Just (IgnoreMajorVersionBumpsSome pkgs) ->-                          let minorSet = S.fromList pkgs-                          in \pkgname -> pkgname `S.member` minorSet-      verbosity     = if quiet then silent else verbosity0--  when (not newFreezeFile && isJust mprojectFile) $-    die' verbosity $-      "--project-file must only be used with --v2-freeze-file."--  sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext-  let pkgIndex = packageIndex sourcePkgDb-  deps <- if freezeFile-          then depsFromFreezeFile verbosity-          else if newFreezeFile-               then depsFromNewFreezeFile verbosity mprojectFile-               else depsFromPkgDesc verbosity comp platform-  debug verbosity $ "Dependencies loaded: "-    ++ (intercalate ", " $ map prettyShow deps)-  let outdatedDeps = listOutdated deps pkgIndex-                     (ListOutdatedSettings ignorePred minorPred)-  when (not quiet) $-    showResult verbosity outdatedDeps simpleOutput-  if (exitCode && (not . null $ outdatedDeps))-    then exitFailure-    else return ()---- | Print either the list of all outdated dependencies, or a message--- that there are none.-showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO ()-showResult verbosity outdatedDeps simpleOutput =-  if (not . null $ outdatedDeps)-    then-    do when (not simpleOutput) $-         notice verbosity "Outdated dependencies:"-       for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->-         let outdatedDep = if simpleOutput then prettyShow pn-                           else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"-         in notice verbosity outdatedDep-    else notice verbosity "All dependencies are up to date."---- | Convert a list of 'UserConstraint's to a 'Dependency' list.-userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint]-userConstraintsToDependencies ucnstrs =-  mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs---- | Read the list of dependencies from the freeze file.-depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]-depsFromFreezeFile verbosity = do-  cwd        <- getCurrentDirectory-  userConfig <- loadUserConfig verbosity cwd Nothing-  let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $-                userConfig-      deps    = userConstraintsToDependencies ucnstrs-  debug verbosity "Reading the list of dependencies from the freeze file"-  return deps---- | Read the list of dependencies from the new-style freeze file.-depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint]-depsFromNewFreezeFile verbosity mprojectFile = do-  projectRoot <- either throwIO return =<<-                 findProjectRoot Nothing mprojectFile-  let distDirLayout = defaultDistDirLayout projectRoot-                      {- TODO: Support dist dir override -} Nothing-  projectConfig  <- runRebuild (distProjectRootDirectory distDirLayout) $-                    readProjectLocalFreezeConfig verbosity distDirLayout-  let ucnstrs = map fst . projectConfigConstraints . projectConfigShared-                $ projectConfig-      deps    = userConstraintsToDependencies ucnstrs-  debug verbosity $-    "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze"-  return deps---- | Read the list of dependencies from the package description.-depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [PackageVersionConstraint]-depsFromPkgDesc verbosity comp platform = do-  cwd  <- getCurrentDirectory-  path <- tryFindPackageDesc verbosity cwd-  gpd  <- readGenericPackageDescription verbosity path-  let cinfo = compilerInfo comp-      epd = finalizePD mempty (ComponentRequestedSpec True True)-            (const True) platform cinfo [] gpd-  case epd of-    Left _        -> die' verbosity "finalizePD failed"-    Right (pd, _) -> do-      let bd = allBuildDepends pd-      debug verbosity-        "Reading the list of dependencies from the package description"-      return $ map toPVC bd-  where-    toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr---- | Various knobs for customising the behaviour of 'listOutdated'.-data ListOutdatedSettings = ListOutdatedSettings {-  -- | Should this package be ignored?-  listOutdatedIgnorePred :: PackageName -> Bool,-  -- | Should major version bumps should be ignored for this package?-  listOutdatedMinorPred  :: PackageName -> Bool-  }---- | Find all outdated dependencies.-listOutdated :: [PackageVersionConstraint]-             -> PackageIndex UnresolvedSourcePackage-             -> ListOutdatedSettings-             -> [(PackageVersionConstraint, Version)]-listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) =-  mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps-  where-    isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)-    isOutdated dep@(PackageVersionConstraint pname vr)-      | ignorePred pname = Nothing-      | otherwise                   =-          let this   = map packageVersion $ lookupDependency pkgIndex pname vr-              latest = lookupLatest dep-          in (\v -> (dep, v)) `fmap` isOutdated' this latest--    isOutdated' :: [Version] -> [Version] -> Maybe Version-    isOutdated' [] _  = Nothing-    isOutdated' _  [] = Nothing-    isOutdated' this latest =-      let this'   = maximum this-          latest' = maximum latest-      in if this' < latest' then Just latest' else Nothing--    lookupLatest :: PackageVersionConstraint -> [Version]-    lookupLatest (PackageVersionConstraint pname vr)-      | minorPred pname =-        map packageVersion $ lookupDependency pkgIndex  pname (relaxMinor vr)-      | otherwise =-        map packageVersion $ lookupPackageName pkgIndex pname--    relaxMinor :: VersionRange -> VersionRange-    relaxMinor vr =-      let vis = asVersionIntervals vr-      in maybe vr relax (safeLast vis)-      where relax (LowerBound v0 _, upper) =-              case upper of-                NoUpperBound     -> vr-                UpperBound _v1 _ -> majorBoundVersion v0
− Distribution/Client/PackageHash.hs 
@@ -1,317 +0,0 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}---- | Functions to calculate nix-style hashes for package ids.------ The basic idea is simple, hash the combination of:------   * the package tarball---   * the ids of all the direct dependencies---   * other local configuration (flags, profiling, etc)----module Distribution.Client.PackageHash (-    -- * Calculating package hashes-    PackageHashInputs(..),-    PackageHashConfigInputs(..),-    PackageSourceHash,-    hashedInstalledPackageId,-    hashPackageHashInputs,-    renderPackageHashInputs,-    -- ** Platform-specific variations-    hashedInstalledPackageIdLong,-    hashedInstalledPackageIdShort,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Package-         ( PackageId, PackageIdentifier(..), mkComponentId-         , PkgconfigName )-import Distribution.System-         ( Platform, OS(Windows, OSX), buildOS )-import Distribution.Types.Flag-         ( FlagAssignment, showFlagAssignment )-import Distribution.Simple.Compiler-         ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)-         , ProfDetailLevel(..), showProfDetailLevel )-import Distribution.Simple.InstallDirs-         ( PathTemplate, fromPathTemplate )-import Distribution.Types.PkgconfigVersion (PkgconfigVersion)-import Distribution.Client.HashValue-import Distribution.Client.Types-         ( InstalledPackageId )-import qualified Distribution.Solver.Types.ComponentDeps as CD--import qualified Data.ByteString.Lazy.Char8 as LBS-import qualified Data.Map as Map-import qualified Data.Set as Set------------------------------------ Calculating package hashes------- | Calculate a 'InstalledPackageId' for a package using our nix-style--- inputs hashing method.------ Note that due to path length limitations on Windows, this function uses--- a different method on Windows that produces shorted package ids.--- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'.----hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId-hashedInstalledPackageId-  | buildOS == Windows = hashedInstalledPackageIdShort-  | buildOS == OSX     = hashedInstalledPackageIdVeryShort-  | otherwise          = hashedInstalledPackageIdLong---- | Calculate a 'InstalledPackageId' for a package using our nix-style--- inputs hashing method.------ This produces large ids with big hashes. It is only suitable for systems--- without significant path length limitations (ie not Windows).----hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId-hashedInstalledPackageIdLong-    pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent}-    = mkComponentId $-           prettyShow pkgHashPkgId   -- to be a bit user friendly-        ++ maybe "" displayComponent pkgHashComponent-        ++ "-"-        ++ showHashValue (hashPackageHashInputs pkghashinputs)-  where-    displayComponent :: CD.Component -> String-    displayComponent CD.ComponentLib        = ""-    displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s-    displayComponent (CD.ComponentFLib s)   = "-f-" ++ prettyShow s-    displayComponent (CD.ComponentExe s)    = "-e-" ++ prettyShow s-    displayComponent (CD.ComponentTest s)   = "-t-" ++ prettyShow s-    displayComponent (CD.ComponentBench s)  = "-b-" ++ prettyShow s-    displayComponent CD.ComponentSetup      = "-setup"---- | On Windows we have serious problems with path lengths. Windows imposes a--- maximum path length of 260 chars, and even if we can use the windows long--- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all--- do so too.------ So our only choice is to limit the lengths of the paths, and the only real--- way to do that is to limit the size of the 'InstalledPackageId's that we--- generate. We do this by truncating the package names and versions and also--- by truncating the hash sizes.------ Truncating the package names and versions is technically ok because they are--- just included for human convenience, the full source package id is included--- in the hash.------ Truncating the hash size is disappointing but also technically ok. We--- rely on the hash primarily for collision avoidance not for any security--- properties (at least for now).----hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId-hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =-    mkComponentId $-      intercalate "-"-        -- max length now 64-        [ truncateStr 14 (prettyShow name)-        , truncateStr  8 (prettyShow version)-        , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))-        ]-  where-    PackageIdentifier name version = pkgHashPkgId--    -- Truncate a string, with a visual indication that it is truncated.-    truncateStr n s | length s <= n = s-                    | otherwise     = take (n-1) s ++ "_"---- | On macOS we shorten the name very aggressively.  The mach-o linker on--- macOS has a limited load command size, to which the name of the library--- as well as its relative path (\@rpath) entry count.  To circumvent this,--- on macOS the libraries are not stored as---  @store/<libraryname>/libHS<libraryname>.dylib@--- where libraryname contains the libraries name, version and abi hash, but in---  @store/lib/libHS<very short libraryname>.dylib@--- where the very short library name drops all vowels from the package name,--- and truncates the hash to 4 bytes.------ We therefore we only need one \@rpath entry to @store/lib@ instead of one--- \@rpath entry for each library. And the reduced library name saves some--- additional space.------ This however has two major drawbacks:--- 1) Packages can collide more easily due to the shortened hash.--- 2) The libraries are *not* prefix relocatable anymore as they all end up---    in the same @store/lib@ folder.------ The ultimate solution would have to include generating proxy dynamic--- libraries on macOS, such that the proxy libraries and the linked libraries--- stay under the load command limit, and the recursive linker is still able--- to link all of them.-hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId-hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =-  mkComponentId $-    intercalate "-"-      [ filter (not . flip elem "aeiou") (prettyShow name)-      , prettyShow version-      , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs))-      ]-  where-    PackageIdentifier name version = pkgHashPkgId---- | All the information that contribues to a package's hash, and thus its--- 'InstalledPackageId'.----data PackageHashInputs = PackageHashInputs {-       pkgHashPkgId         :: PackageId,-       pkgHashComponent     :: Maybe CD.Component,-       pkgHashSourceHash    :: PackageSourceHash,-       pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion),-       pkgHashDirectDeps    :: Set InstalledPackageId,-       pkgHashOtherConfig   :: PackageHashConfigInputs-     }--type PackageSourceHash = HashValue---- | Those parts of the package configuration that contribute to the--- package hash.----data PackageHashConfigInputs = PackageHashConfigInputs {-       pkgHashCompilerId          :: CompilerId,-       pkgHashPlatform            :: Platform,-       pkgHashFlagAssignment      :: FlagAssignment, -- complete not partial-       pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure-       pkgHashVanillaLib          :: Bool,-       pkgHashSharedLib           :: Bool,-       pkgHashDynExe              :: Bool,-       pkgHashFullyStaticExe      :: Bool,-       pkgHashGHCiLib             :: Bool,-       pkgHashProfLib             :: Bool,-       pkgHashProfExe             :: Bool,-       pkgHashProfLibDetail       :: ProfDetailLevel,-       pkgHashProfExeDetail       :: ProfDetailLevel,-       pkgHashCoverage            :: Bool,-       pkgHashOptimization        :: OptimisationLevel,-       pkgHashSplitObjs           :: Bool,-       pkgHashSplitSections       :: Bool,-       pkgHashStripLibs           :: Bool,-       pkgHashStripExes           :: Bool,-       pkgHashDebugInfo           :: DebugInfoLevel,-       pkgHashProgramArgs         :: Map String [String],-       pkgHashExtraLibDirs        :: [FilePath],-       pkgHashExtraFrameworkDirs  :: [FilePath],-       pkgHashExtraIncludeDirs    :: [FilePath],-       pkgHashProgPrefix          :: Maybe PathTemplate,-       pkgHashProgSuffix          :: Maybe PathTemplate,--       -- Haddock options-       pkgHashDocumentation       :: Bool,-       pkgHashHaddockHoogle       :: Bool,-       pkgHashHaddockHtml         :: Bool,-       pkgHashHaddockHtmlLocation :: Maybe String,-       pkgHashHaddockForeignLibs  :: Bool,-       pkgHashHaddockExecutables  :: Bool,-       pkgHashHaddockTestSuites   :: Bool,-       pkgHashHaddockBenchmarks   :: Bool,-       pkgHashHaddockInternal     :: Bool,-       pkgHashHaddockCss          :: Maybe FilePath,-       pkgHashHaddockLinkedSource :: Bool,-       pkgHashHaddockQuickJump    :: Bool,-       pkgHashHaddockContents     :: Maybe PathTemplate----     TODO: [required eventually] pkgHashToolsVersions     ?---     TODO: [required eventually] pkgHashToolsExtraOptions ?-     }-  deriving Show----- | Calculate the overall hash to be used for an 'InstalledPackageId'.----hashPackageHashInputs :: PackageHashInputs -> HashValue-hashPackageHashInputs = hashValue . renderPackageHashInputs---- | Render a textual representation of the 'PackageHashInputs'.------ The 'hashValue' of this text is the overall package hash.----renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString-renderPackageHashInputs PackageHashInputs{-                          pkgHashPkgId,-                          pkgHashComponent,-                          pkgHashSourceHash,-                          pkgHashDirectDeps,-                          pkgHashPkgConfigDeps,-                          pkgHashOtherConfig =-                            PackageHashConfigInputs{..}-                        } =-    -- The purpose of this somewhat laboured rendering (e.g. why not just-    -- use show?) is so that existing package hashes do not change-    -- unnecessarily when new configuration inputs are added into the hash.--    -- In particular, the assumption is that when a new configuration input-    -- is included into the hash, that existing packages will typically get-    -- the default value for that feature. So if we avoid adding entries with-    -- the default value then most of the time adding new features will not-    -- change the hashes of existing packages and so fewer packages will need-    -- to be rebuilt.--    --TODO: [nice to have] ultimately we probably want to put this config info-    -- into the ghc-pkg db. At that point this should probably be changed to-    -- use the config file infrastructure so it can be read back in again.-    LBS.pack $ unlines $ catMaybes $-      [ entry "pkgid"       prettyShow pkgHashPkgId-      , mentry "component"  show pkgHashComponent-      , entry "src"         showHashValue pkgHashSourceHash-      , entry "pkg-config-deps"-                            (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++-                                                    case mb_v of-                                                        Nothing -> ""-                                                        Just v -> " " ++ prettyShow v)-                                              . Set.toList) pkgHashPkgConfigDeps-      , entry "deps"        (intercalate ", " . map prettyShow-                                              . Set.toList) pkgHashDirectDeps-        -- and then all the config-      , entry "compilerid"  prettyShow pkgHashCompilerId-      , entry "platform" prettyShow pkgHashPlatform-      , opt   "flags" mempty showFlagAssignment pkgHashFlagAssignment-      , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs-      , opt   "vanilla-lib" True  prettyShow pkgHashVanillaLib-      , opt   "shared-lib"  False prettyShow pkgHashSharedLib-      , opt   "dynamic-exe" False prettyShow pkgHashDynExe-      , opt   "fully-static-exe" False prettyShow pkgHashFullyStaticExe-      , opt   "ghci-lib"    False prettyShow pkgHashGHCiLib-      , opt   "prof-lib"    False prettyShow pkgHashProfLib-      , opt   "prof-exe"    False prettyShow pkgHashProfExe-      , opt   "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail-      , opt   "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail-      , opt   "hpc"          False prettyShow pkgHashCoverage-      , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization-      , opt   "split-objs"   False prettyShow pkgHashSplitObjs-      , opt   "split-sections" False prettyShow pkgHashSplitSections-      , opt   "stripped-lib" False prettyShow pkgHashStripLibs-      , opt   "stripped-exe" True  prettyShow pkgHashStripExes-      , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo-      , opt   "extra-lib-dirs"     [] unwords pkgHashExtraLibDirs-      , opt   "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs-      , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs-      , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix-      , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix--      , opt   "documentation"  False prettyShow pkgHashDocumentation-      , opt   "haddock-hoogle" False prettyShow pkgHashHaddockHoogle-      , opt   "haddock-html"   False prettyShow pkgHashHaddockHtml-      , opt   "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation-      , opt   "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs-      , opt   "haddock-executables" False prettyShow pkgHashHaddockExecutables-      , opt   "haddock-tests" False prettyShow pkgHashHaddockTestSuites-      , opt   "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks-      , opt   "haddock-internal" False prettyShow pkgHashHaddockInternal-      , opt   "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss-      , opt   "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource-      , opt   "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump-      , opt   "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents--      ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs-  where-    entry key     format value = Just (key ++ ": " ++ format value)-    mentry key    format value = fmap (\v -> key ++ ": " ++ format v) value-    opt   key def format value-         | value == def = Nothing-         | otherwise    = entry key format value
− Distribution/Client/ParseUtils.hs 
@@ -1,374 +0,0 @@-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.ParseUtils--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Parsing utilities.--------------------------------------------------------------------------------module Distribution.Client.ParseUtils (--    -- * Fields and field utilities-    FieldDescr(..),-    liftField,-    liftFields,-    filterFields,-    mapFieldNames,-    commandOptionToField,-    commandOptionsToFields,--    -- * Sections and utilities-    SectionDescr(..),-    liftSection,--    -- * FieldGrammar sections-    FGSectionDescr(..),--    -- * Parsing and printing flat config-    parseFields,-    ppFields,-    ppSection,--    -- * Parsing and printing config with sections and subsections-    parseFieldsAndSections,-    ppFieldsAndSections,--    -- ** Top level of config files-    parseConfig,-    showConfig,-  )-       where--import Distribution.Client.Compat.Prelude hiding (empty, get)-import Prelude ()--import Distribution.Deprecated.ParseUtils-         ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo-         , Field(..), liftField, readFieldsFlat )-import Distribution.Deprecated.ViewAsFieldDescr-         ( viewAsFieldDescr )--import Distribution.Simple.Command-         ( OptionField  )--import Text.PrettyPrint ( ($+$) )-import qualified Data.Map as Map-import qualified Text.PrettyPrint as Disp-         ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )---- For new parser stuff-import Distribution.CabalSpecVersion (cabalSpecLatest)-import Distribution.FieldGrammar (partitionFields, parseFieldGrammar)-import Distribution.Fields.ParseResult (runParseResult)-import Distribution.Parsec.Error (showPError)-import Distribution.Parsec.Position (Position (..))-import Distribution.Parsec.Warning (showPWarning)-import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)-import qualified Distribution.Fields as F-import qualified Distribution.FieldGrammar as FG------------------------------- FieldDescr utilities-----liftFields :: (b -> a)-           -> (a -> b -> b)-           -> [FieldDescr a]-           -> [FieldDescr b]-liftFields get set = map (liftField get set)----- | Given a collection of field descriptions, keep only a given list of them,--- identified by name.----filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]-filterFields includeFields = filter ((`elem` includeFields) . fieldName)---- | Apply a name mangling function to the field names of all the field--- descriptions. The typical use case is to apply some prefix.----mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]-mapFieldNames mangleName =-    map (\descr -> descr { fieldName = mangleName (fieldName descr) })----- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.----commandOptionToField :: OptionField a -> FieldDescr a-commandOptionToField = viewAsFieldDescr---- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.----commandOptionsToFields :: [OptionField a] -> [FieldDescr a]-commandOptionsToFields = map viewAsFieldDescr------------------------------------------------ SectionDescr definition and utilities------- | The description of a section in a config file. It can contain both--- fields and optionally further subsections. See also 'FieldDescr'.----data SectionDescr a = forall b. SectionDescr {-       sectionName        :: String,-       sectionFields      :: [FieldDescr b],-       sectionSubsections :: [SectionDescr b],-       sectionGet         :: a -> [(String, b)],-       sectionSet         :: LineNo -> String -> b -> a -> ParseResult a,-       sectionEmpty       :: b-     }---- | 'FieldGrammar' section description-data FGSectionDescr g a = forall s. FGSectionDescr-    { fgSectionName    :: String-    , fgSectionGrammar :: g s s-    -- todo: add subsections?-    , fgSectionGet     :: a -> [(String, s)]-    , fgSectionSet     :: LineNo -> String -> s -> a -> ParseResult a-    }---- | To help construction of config file descriptions in a modular way it is--- useful to define fields and sections on local types and then hoist them--- into the parent types when combining them in bigger descriptions.------ This is essentially a lens operation for 'SectionDescr' to help embedding--- one inside another.----liftSection :: (b -> a)-            -> (a -> b -> b)-            -> SectionDescr a-            -> SectionDescr b-liftSection get' set' (SectionDescr name fields sections get set empty) =-    let sectionGet' = get . get'-        sectionSet' lineno param x y = do-          x' <- set lineno param x (get' y)-          return (set' x' y)-     in SectionDescr name fields sections sectionGet' sectionSet' empty------------------------------------------- Parsing and printing flat config------- | Parse a bunch of semi-parsed 'Field's according to a set of field--- descriptions. It accumulates the result on top of a given initial value.------ This only covers the case of flat configuration without subsections. See--- also 'parseFieldsAndSections'.----parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a-parseFields fieldDescrs =-    foldM setField-  where-    fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]--    setField accum (F line name value) =-      case Map.lookup name fieldMap of-        Just (FieldDescr _ _ set) -> set line value accum-        Nothing -> do-          warning $ "Unrecognized field " ++ name ++ " on line " ++ show line-          return accum--    setField accum f = do-      warning $ "Unrecognized stanza on line " ++ show (lineNo f)-      return accum---- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils--- that also optionally print default values for empty fields as comments.----ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc-ppFields fields def cur =-    Disp.vcat [ ppField name (fmap getter def) (getter cur)-              | FieldDescr name getter _ <- fields]--ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc-ppField name mdef cur-  | Disp.isEmpty cur = maybe Disp.empty-                       (\def -> Disp.text "--" <+> Disp.text name-                                Disp.<> Disp.colon <+> def) mdef-  | otherwise        = Disp.text name Disp.<> Disp.colon <+> cur---- | Pretty print a section.------ Since 'ppFields' does not cover subsections you can use this to add them.--- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.----ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc-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----------------------------------------------- Parsing and printing non-flat config------- | Much like 'parseFields' but it also allows subsections. The permitted--- subsections are given by a list of 'SectionDescr's.----parseFieldsAndSections-    :: [FieldDescr a]      -- ^ field-    -> [SectionDescr a]    -- ^ legacy sections-    -> [FGSectionDescr FG.ParsecFieldGrammar a]  -- ^ FieldGrammar sections-    -> a-    -> [Field] -> ParseResult a-parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =-    foldM setField-  where-    fieldMap     = Map.fromList [ (fieldName     f, f) | f <- fieldDescrs     ]-    sectionMap   = Map.fromList [ (sectionName   s, s) | s <- sectionDescrs   ]-    fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ]--    setField a (F line name value) =-      case Map.lookup name fieldMap of-        Just (FieldDescr _ _ set) -> set line value a-        Nothing -> do-          warning $ "Unrecognized field '" ++ name-                 ++ "' on line " ++ show line-          return a--    setField a (Section line name param fields) =-      case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of-        Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do-          b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields-          set line param b a-        Just (Right (FGSectionDescr _ grammar _getter setter)) -> do-          let fields1 = mapMaybe convertField fields-              (fields2, sections) = partitionFields fields1-          -- TODO: recurse into sections-          for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->-            warning $ "Unrecognized section '" ++ fromUTF8BS name'-              ++ "' on line " ++ show line'-          case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of-            (warnings, Right b) -> do-              for_ warnings $ \w -> warning $ showPWarning "???" w-              setter line param b a-            (warnings, Left (_, errs)) -> do-              for_ warnings $ \w -> warning $ showPWarning "???" w-              case errs of-                err :| _errs -> fail $ showPError "???" err-        Nothing -> do-          warning $ "Unrecognized section '" ++ name-                 ++ "' on line " ++ show line-          return a--    setField accum (block@IfBlock {}) = do-      warning $ "Unrecognized stanza on line " ++ show (lineNo block)-      return accum--convertField :: Field -> Maybe (F.Field Position)-convertField (F line name str) = Just $-    F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]-  where-    pos = Position line 0--- arguments omitted-convertField (Section line name _arg fields) = Just $-    F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields)-  where-    pos = Position line 0--- silently omitted.-convertField IfBlock {} = Nothing----- | Much like 'ppFields' but also pretty prints any subsections. Subsection--- are only shown if they are non-empty.------ Note that unlike 'ppFields', at present it does not support printing--- default values. If needed, adding such support would be quite reasonable.----ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc-ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =-    ppFields fieldDescrs Nothing val-      $+$-    Disp.vcat (-      [ Disp.text "" $+$ sectionDoc-      | SectionDescr {-          sectionName, sectionGet,-          sectionFields, sectionSubsections-        } <- sectionDescrs-      , (param, x) <- sectionGet val-      , let sectionDoc = ppSectionAndSubsections-                           sectionName param-                           sectionFields sectionSubsections [] x-      , not (Disp.isEmpty sectionDoc)-      ] ++-      [ Disp.text "" $+$ sectionDoc-      | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs-      , (param, x) <- fgSectionGet val-      , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x-      , not (Disp.isEmpty sectionDoc)-      ])---- | Unlike 'ppSection' which has to be called directly, this gets used via--- 'ppFieldsAndSections' and so does not need to be exported.----ppSectionAndSubsections :: String -> String-                        -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar  a] -> a -> Disp.Doc-ppSectionAndSubsections name arg fields sections fgSections cur-  | Disp.isEmpty fieldsDoc = Disp.empty-  | otherwise              = Disp.text name <+> argDoc-                             $+$ (Disp.nest 2 fieldsDoc)-  where-    fieldsDoc = showConfig fields sections fgSections cur-    argDoc | arg == "" = Disp.empty-           | otherwise = Disp.text arg---- |------ TODO: subsections--- TODO: this should simply build 'PrettyField'-ppFgSection-    :: String  -- ^ section name-    -> String  -- ^ parameter-    -> FG.PrettyFieldGrammar a a-    -> a-    -> Disp.Doc-ppFgSection secName arg grammar x-    | null prettyFields = Disp.empty-    | otherwise         =-        Disp.text secName <+> argDoc-        $+$ (Disp.nest 2 fieldsDoc)-  where-    prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x--    argDoc | arg == "" = Disp.empty-           | otherwise = Disp.text arg--    fieldsDoc = Disp.vcat-        [ Disp.text fname' <<>> Disp.colon <<>> doc-        | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections-        , let fname' = fromUTF8BS fname-        ]----------------------------------------------------- Top level config file parsing and printing------- | Parse a string in the config file syntax into a value, based on a--- description of the configuration file in terms of its fields and sections.------ It accumulates the result on top of a given initial (typically empty) value.----parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a-            -> String -> ParseResult a-parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =-      parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty-  =<< readFieldsFlat str---- | Render a value in the config file syntax, based on a description of the--- configuration file in terms of its fields and sections.----showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc-showConfig = ppFieldsAndSections-
− Distribution/Client/ProjectBuilding.hs 
@@ -1,1475 +0,0 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE NoMonoLocalBinds    #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}---- |----module Distribution.Client.ProjectBuilding (-    -- * Dry run phase-    -- | What bits of the plan will we execute? The dry run does not change-    -- anything but tells us what will need to be built.-    rebuildTargetsDryRun,-    improveInstallPlanWithUpToDatePackages,--    -- ** Build status-    -- | This is the detailed status information we get from the dry run.-    BuildStatusMap,-    BuildStatus(..),-    BuildStatusRebuild(..),-    BuildReason(..),-    MonitorChangedReason(..),-    buildStatusToString,--    -- * Build phase-    -- | Now we actually execute the plan.-    rebuildTargets,-    -- ** Build outcomes-    -- | This is the outcome for each package of executing the plan.-    -- For each package, did the build succeed or fail?-    BuildOutcomes,-    BuildOutcome,-    BuildResult(..),-    BuildFailure(..),-    BuildFailureReason(..),-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import           Distribution.Client.PackageHash (renderPackageHashInputs)-import           Distribution.Client.RebuildMonad-import           Distribution.Client.ProjectConfig-import           Distribution.Client.ProjectPlanning-import           Distribution.Client.ProjectPlanning.Types-import           Distribution.Client.ProjectBuilding.Types-import           Distribution.Client.Store--import           Distribution.Client.Types-                   hiding (BuildOutcomes, BuildOutcome,-                           BuildResult(..), BuildFailure(..))-import           Distribution.Client.InstallPlan-                   ( GenericInstallPlan, GenericPlanPackage, IsUnit )-import qualified Distribution.Client.InstallPlan as InstallPlan-import           Distribution.Client.DistDirLayout-import           Distribution.Client.FileMonitor-import           Distribution.Client.SetupWrapper-import           Distribution.Client.JobControl-import           Distribution.Client.FetchUtils-import           Distribution.Client.GlobalFlags (RepoContext)-import qualified Distribution.Client.Tar as Tar-import           Distribution.Client.Setup-                   ( filterConfigureFlags, filterHaddockArgs-                   , filterHaddockFlags, filterTestFlags )-import           Distribution.Client.SourceFiles-import           Distribution.Client.SrcDist (allPackageSourceFiles)-import           Distribution.Client.Utils-                   ( ProgressPhase(..), progressMessage, removeExistingFile )--import           Distribution.Compat.Lens-import           Distribution.Package-import qualified Distribution.PackageDescription as PD-import           Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.InstalledPackageInfo as Installed-import           Distribution.Simple.BuildPaths (haddockDirName)-import qualified Distribution.Simple.InstallDirs as InstallDirs-import           Distribution.Types.BuildType-import           Distribution.Types.PackageDescription.Lens (componentModules)-import           Distribution.Simple.Program-import qualified Distribution.Simple.Setup as Cabal-import           Distribution.Simple.Command (CommandUI)-import qualified Distribution.Simple.Register as Cabal-import           Distribution.Simple.LocalBuildInfo-                   ( ComponentName(..), LibraryName(..) )-import           Distribution.Simple.Compiler-                   ( Compiler, compilerId, PackageDB(..) )--import           Distribution.Simple.Utils-import           Distribution.Version-import           Distribution.Compat.Graph (IsNode(..))--import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS--import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)-import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)-import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))-import System.IO         (IOMode (AppendMode), withFile)--import Distribution.Compat.Directory (listDirectory)------------------------------------------------------------------------------------ * Overall building strategy.------------------------------------------------------------------------------------- We start with an 'ElaboratedInstallPlan' that has already been improved by--- reusing packages from the store, and pruned to include only the targets of--- interest and their dependencies. So the remaining packages in the--- 'InstallPlan.Configured' state are ones we either need to build or rebuild.------ First, we do a preliminary dry run phase where we work out which packages--- we really need to (re)build, and for the ones we do need to build which--- build phase to start at.------ We use this to improve the 'ElaboratedInstallPlan' again by changing--- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'--- so that the build phase will skip them.------ Then we execute the plan, that is actually build packages. The outcomes of--- trying to build all the packages are collected and returned.------ We split things like this (dry run and execute) for a couple reasons.--- Firstly we need to be able to do dry runs anyway, and these need to be--- reasonably accurate in terms of letting users know what (and why) things--- are going to be (re)built.------ Given that we need to be able to do dry runs, it would not be great if--- we had to repeat all the same work when we do it for real. Not only is--- it duplicate work, but it's duplicate code which is likely to get out of--- sync. So we do things only once. We preserve info we discover in the dry--- run phase and rely on it later when we build things for real. This also--- somewhat simplifies the build phase. So this way the dry run can't so--- easily drift out of sync with the real thing since we're relying on the--- info it produces.------ An additional advantage is that it makes it easier to debug rebuild--- errors (ie rebuilding too much or too little), since all the rebuild--- decisions are made without making any state changes at the same time--- (that would make it harder to reproduce the problem situation).------ Finally, we can use the dry run build status and the build outcomes to--- give us some information on the overall status of packages in the project.--- This includes limited information about the status of things that were--- not actually in the subset of the plan that was used for the dry run or--- execution phases. In particular we may know that some packages are now--- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for--- details.------------------------------------------------------------------------------------ * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?----------------------------------------------------------------------------------- Refer to ProjectBuilding.Types for details of these important types:---- type BuildStatusMap     = ...--- data BuildStatus        = ...--- data BuildStatusRebuild = ...--- data BuildReason        = ...---- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.------ It gives us the 'BuildStatusMap'. This should be used with--- 'improveInstallPlanWithUpToDatePackages' to give an improved version of--- the 'ElaboratedInstallPlan' with packages switched to the--- 'InstallPlan.Installed' state when we find that they're already up to date.----rebuildTargetsDryRun :: DistDirLayout-                     -> ElaboratedSharedConfig-                     -> ElaboratedInstallPlan-                     -> IO BuildStatusMap-rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =-    -- Do the various checks to work out the 'BuildStatus' of each package-    foldMInstallPlanDepOrder dryRunPkg-  where-    dryRunPkg :: ElaboratedPlanPackage-              -> [BuildStatus]-              -> IO BuildStatus-    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =-      return BuildStatusPreExisting--    dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =-      return BuildStatusInstalled--    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do-      mloc <- checkFetched (elabPkgSourceLocation pkg)-      case mloc of-        Nothing -> return BuildStatusDownload--        Just (LocalUnpackedPackage srcdir) ->-          -- For the case of a user-managed local dir, irrespective of the-          -- build style, we build from that directory and put build-          -- artifacts under the shared dist directory.-          dryRunLocalPkg pkg depsBuildStatus srcdir--        -- The rest cases are all tarball cases are,-        -- and handled the same as each other though depending on the build style.-        Just (LocalTarballPackage    tarball) ->-          dryRunTarballPkg pkg depsBuildStatus tarball--        Just (RemoteTarballPackage _ tarball) ->-          dryRunTarballPkg pkg depsBuildStatus tarball--        Just (RepoTarballPackage _ _ tarball) ->-          dryRunTarballPkg pkg depsBuildStatus tarball--        Just (RemoteSourceRepoPackage _repo tarball) ->-          dryRunTarballPkg pkg depsBuildStatus tarball---    dryRunTarballPkg :: ElaboratedConfiguredPackage-                     -> [BuildStatus]-                     -> FilePath-                     -> IO BuildStatus-    dryRunTarballPkg pkg depsBuildStatus tarball =-      case elabBuildStyle pkg of-        BuildAndInstall  -> return (BuildStatusUnpack tarball)-        BuildInplaceOnly -> do-          -- TODO: [nice to have] use a proper file monitor rather-          -- than this dir exists test-          exists <- doesDirectoryExist srcdir-          if exists-            then dryRunLocalPkg pkg depsBuildStatus srcdir-            else return (BuildStatusUnpack tarball)-      where-        srcdir = distUnpackedSrcDirectory (packageId pkg)--    dryRunLocalPkg :: ElaboratedConfiguredPackage-                   -> [BuildStatus]-                   -> FilePath-                   -> IO BuildStatus-    dryRunLocalPkg pkg depsBuildStatus srcdir = do-        -- Go and do lots of I/O, reading caches and probing files to work out-        -- if anything has changed-        change <- checkPackageFileMonitorChanged-                    packageFileMonitor pkg srcdir depsBuildStatus-        case change of-          -- It did change, giving us 'BuildStatusRebuild' info on why-          Left rebuild ->-            return (BuildStatusRebuild srcdir rebuild)--          -- No changes, the package is up to date. Use the saved build results.-          Right buildResult ->-            return (BuildStatusUpToDate buildResult)-      where-        packageFileMonitor =-          newPackageFileMonitor shared distDirLayout-          (elabDistDirParams shared pkg)----- | A specialised traversal over the packages in an install plan.------ The packages are visited in dependency order, starting with packages with no--- dependencies. The result for each package is accumulated into a 'Map' and--- returned as the final result. In addition, when visiting a package, the--- visiting function is passed the results for all the immediate package--- dependencies. This can be used to propagate information from dependencies.----foldMInstallPlanDepOrder-  :: forall m ipkg srcpkg b.-     (Monad m, IsUnit ipkg, IsUnit srcpkg)-  => (GenericPlanPackage ipkg srcpkg ->-      [b] -> m b)-  -> GenericInstallPlan ipkg srcpkg-  -> m (Map UnitId b)-foldMInstallPlanDepOrder visit =-    go Map.empty . InstallPlan.reverseTopologicalOrder-  where-    go :: Map UnitId b-       -> [GenericPlanPackage ipkg srcpkg]-       -> m (Map UnitId b)-    go !results [] = return results--    go !results (pkg : pkgs) = do-      -- we go in the right order so the results map has entries for all deps-      let depresults :: [b]-          depresults =-            map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results-                              in result)-                (InstallPlan.depends pkg)-      result <- visit pkg depresults-      let results' = Map.insert (nodeKey pkg) result results-      go results' pkgs--improveInstallPlanWithUpToDatePackages :: BuildStatusMap-                                       -> ElaboratedInstallPlan-                                       -> ElaboratedInstallPlan-improveInstallPlanWithUpToDatePackages pkgsBuildStatus =-    InstallPlan.installed canPackageBeImproved-  where-    canPackageBeImproved pkg =-      case Map.lookup (installedUnitId pkg) pkgsBuildStatus of-        Just BuildStatusUpToDate {} -> True-        Just _                      -> False-        Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "-                        ++ prettyShow (packageId pkg) ++ " not in status map"----------------------------------- Package change detection------- | As part of the dry run for local unpacked packages we have to check if the--- package config or files have changed. That is the purpose of--- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.------ When a package is (re)built, the monitor must be updated to reflect the new--- state of the package. Because we sometimes build without reconfiguring the--- state updates are split into two, one for package config changes and one--- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'--- and 'updatePackageBuildFileMonitor'.----data PackageFileMonitor = PackageFileMonitor {-       pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),-       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,-       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)-     }---- | This is all the components of the 'BuildResult' other than the--- @['InstalledPackageInfo']@.------ We have to split up the 'BuildResult' components since they get produced--- at different times (or rather, when different things change).----type BuildResultMisc = (DocsResult, TestsResult)--newPackageFileMonitor :: ElaboratedSharedConfig-                      -> DistDirLayout-                      -> DistDirParams-                      -> PackageFileMonitor-newPackageFileMonitor shared-                      DistDirLayout{distPackageCacheFile}-                      dparams =-    PackageFileMonitor {-      pkgFileMonitorConfig =-        FileMonitor {-          fileMonitorCacheFile = distPackageCacheFile dparams "config",-          fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared,-          fileMonitorCheckIfOnlyValueChanged = False-        },--      pkgFileMonitorBuild =-        FileMonitor {-          fileMonitorCacheFile = distPackageCacheFile dparams "build",-          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->-            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,-          fileMonitorCheckIfOnlyValueChanged = True-        },--      pkgFileMonitorReg =-        newFileMonitor (distPackageCacheFile dparams "registration")-    }---- | Helper function for 'checkPackageFileMonitorChanged',--- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.------ It selects the info from a 'ElaboratedConfiguredPackage' that are used by--- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.----packageFileMonitorKeyValues :: ElaboratedConfiguredPackage-                            -> (ElaboratedConfiguredPackage, Set ComponentName)-packageFileMonitorKeyValues elab =-    (elab_config, buildComponents)-  where-    -- The first part is the value used to guard (re)configuring the package.-    -- That is, if this value changes then we will reconfigure.-    -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of-    -- information that affects the (re)configure step. But those parts that-    -- do not affect the configure step need to be nulled out. Those parts are-    -- the specific targets that we're going to build.-    ---    elab_config =-        elab {-            elabBuildTargets   = [],-            elabTestTargets    = [],-            elabBenchTargets   = [],-            elabReplTarget     = Nothing,-            elabHaddockTargets = [],-            elabBuildHaddocks  = False-        }--    -- The second part is the value used to guard the build step. So this is-    -- more or less the opposite of the first part, as it's just the info about-    -- what targets we're going to build.-    ---    buildComponents = elabBuildTargetWholeComponents elab---- | Do all the checks on whether a package has changed and thus needs either--- rebuilding or reconfiguring and rebuilding.----checkPackageFileMonitorChanged :: PackageFileMonitor-                               -> ElaboratedConfiguredPackage-                               -> FilePath-                               -> [BuildStatus]-                               -> IO (Either BuildStatusRebuild BuildResult)-checkPackageFileMonitorChanged PackageFileMonitor{..}-                               pkg srcdir depsBuildStatus = do-    --TODO: [nice to have] some debug-level message about file-    --changes, like rerunIfChanged-    configChanged <- checkFileMonitorChanged-                       pkgFileMonitorConfig srcdir pkgconfig-    case configChanged of-      MonitorChanged monitorReason ->-          return (Left (BuildStatusConfigure monitorReason'))-        where-          monitorReason' = fmap (const ()) monitorReason--      MonitorUnchanged () _-          -- The configChanged here includes the identity of the dependencies,-          -- so depsBuildStatus is just needed for the changes in the content-          -- of dependencies.-        | any buildStatusRequiresBuild depsBuildStatus -> do-            regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()-            let mreg = changedToMaybe regChanged-            return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))--        | otherwise -> do-            buildChanged  <- checkFileMonitorChanged-                               pkgFileMonitorBuild srcdir buildComponents-            regChanged    <- checkFileMonitorChanged-                               pkgFileMonitorReg srcdir ()-            let mreg = changedToMaybe regChanged-            case (buildChanged, regChanged) of-              (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->-                  return (Left (BuildStatusBuild mreg buildReason))-                where-                  buildReason = BuildReasonExtraTargets prevBuildComponents--              (MonitorChanged monitorReason, _) ->-                  return (Left (BuildStatusBuild mreg buildReason))-                where-                  buildReason    = BuildReasonFilesChanged monitorReason'-                  monitorReason' = fmap (const ()) monitorReason--              (MonitorUnchanged _ _, MonitorChanged monitorReason) ->-                -- this should only happen if the file is corrupt or been-                -- manually deleted. We don't want to bother with another-                -- phase just for this, so we'll reregister by doing a build.-                  return (Left (BuildStatusBuild Nothing buildReason))-                where-                  buildReason    = BuildReasonFilesChanged monitorReason'-                  monitorReason' = fmap (const ()) monitorReason--              (MonitorUnchanged _ _, MonitorUnchanged _ _)-                | pkgHasEphemeralBuildTargets pkg ->-                  return (Left (BuildStatusBuild mreg buildReason))-                where-                  buildReason = BuildReasonEphemeralTargets--              (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->-                  return $ Right BuildResult {-                    buildResultDocs    = docsResult,-                    buildResultTests   = testsResult,-                    buildResultLogFile = Nothing-                  }-                where-                  (docsResult, testsResult) = buildResult-  where-    (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg-    changedToMaybe (MonitorChanged     _) = Nothing-    changedToMaybe (MonitorUnchanged x _) = Just x---updatePackageConfigFileMonitor :: PackageFileMonitor-                               -> FilePath-                               -> ElaboratedConfiguredPackage-                               -> IO ()-updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}-                               srcdir pkg =-    updateFileMonitor pkgFileMonitorConfig srcdir Nothing-                      [] pkgconfig ()-  where-    (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg--updatePackageBuildFileMonitor :: PackageFileMonitor-                              -> FilePath-                              -> MonitorTimestamp-                              -> ElaboratedConfiguredPackage-                              -> BuildStatusRebuild-                              -> [MonitorFilePath]-                              -> BuildResultMisc-                              -> IO ()-updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}-                              srcdir timestamp pkg pkgBuildStatus-                              monitors buildResult =-    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)-                      monitors buildComponents' buildResult-  where-    (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg--    -- If the only thing that's changed is that we're now building extra-    -- components, then we can avoid later unnecessary rebuilds by saving the-    -- total set of components that have been built, namely the union of the-    -- existing ones plus the new ones. If files also changed this would be-    -- the wrong thing to do. Note that we rely on the-    -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee-    -- that it's /only/ the value that changed not any files that changed.-    buildComponents' =-      case pkgBuildStatus of-        BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)-          -> buildComponents `Set.union` prevBuildComponents-        _ -> buildComponents--updatePackageRegFileMonitor :: PackageFileMonitor-                            -> FilePath-                            -> Maybe InstalledPackageInfo-                            -> IO ()-updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}-                            srcdir mipkg =-    updateFileMonitor pkgFileMonitorReg srcdir Nothing-                      [] () mipkg--invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()-invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =-    removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)------------------------------------------------------------------------------------ * Doing it: executing an 'ElaboratedInstallPlan'----------------------------------------------------------------------------------- Refer to ProjectBuilding.Types for details of these important types:---- type BuildOutcomes = ...--- type BuildOutcome  = ...--- data BuildResult   = ...--- data BuildFailure  = ...--- data BuildFailureReason = ...---- | Build things for real.------ It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.----rebuildTargets :: Verbosity-               -> DistDirLayout-               -> StoreDirLayout-               -> ElaboratedInstallPlan-               -> ElaboratedSharedConfig-               -> BuildStatusMap-               -> BuildTimeSettings-               -> IO BuildOutcomes-rebuildTargets verbosity-               distDirLayout@DistDirLayout{..}-               storeDirLayout-               installPlan-               sharedPackageConfig@ElaboratedSharedConfig {-                 pkgConfigCompiler      = compiler,-                 pkgConfigCompilerProgs = progdb-               }-               pkgsBuildStatus-               buildSettings@BuildTimeSettings{-                 buildSettingNumJobs,-                 buildSettingKeepGoing-               } = do--    -- Concurrency control: create the job controller and concurrency limits-    -- for downloading, building and installing.-    jobControl    <- if isParallelBuild-                       then newParallelJobControl buildSettingNumJobs-                       else newSerialJobControl-    registerLock  <- newLock -- serialise registration-    cacheLock     <- newLock -- serialise access to setup exe cache-                             --TODO: [code cleanup] eliminate setup exe cache--    debug verbosity $-        "Executing install plan "-     ++ if isParallelBuild-          then " in parallel using " ++ show buildSettingNumJobs ++ " threads."-          else " serially."--    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory-    createDirectoryIfMissingVerbose verbosity True distTempDirectory-    traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse--    -- Before traversing the install plan, pre-emptively find all packages that-    -- will need to be downloaded and start downloading them.-    asyncDownloadPackages verbosity withRepoCtx-                          installPlan pkgsBuildStatus $ \downloadMap ->--      -- For each package in the plan, in dependency order, but in parallel...-      InstallPlan.execute jobControl keepGoing-                          (BuildFailure Nothing . DependentFailed . packageId)-                          installPlan $ \pkg ->-        --TODO: review exception handling-        handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $--        let uid = installedUnitId pkg-            pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in--        rebuildTarget-          verbosity-          distDirLayout-          storeDirLayout-          buildSettings downloadMap-          registerLock cacheLock-          sharedPackageConfig-          installPlan pkg-          pkgBuildStatus-  where-    isParallelBuild = buildSettingNumJobs >= 2-    keepGoing       = buildSettingKeepGoing-    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity-                        buildSettings-    packageDBsToUse = -- all the package dbs we may need to create-      (Set.toList . Set.fromList)-        [ pkgdb-        | InstallPlan.Configured elab <- InstallPlan.toList installPlan-        , pkgdb <- concat [ elabBuildPackageDBStack elab-                          , elabRegisterPackageDBStack elab-                          , elabSetupPackageDBStack elab ]-        ]----- | Create a package DB if it does not currently exist. Note that this action--- is /not/ safe to run concurrently.----createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb-                         -> PackageDB -> IO ()-createPackageDBIfMissing verbosity compiler progdb-                         (SpecificPackageDB dbPath) = do-    exists <- Cabal.doesPackageDBExist dbPath-    unless exists $ do-      createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)-      Cabal.createPackageDB verbosity compiler progdb False dbPath-createPackageDBIfMissing _ _ _ _ = return ()----- | Given all the context and resources, (re)build an individual package.----rebuildTarget :: Verbosity-              -> DistDirLayout-              -> StoreDirLayout-              -> BuildTimeSettings-              -> AsyncFetchMap-              -> Lock -> Lock-              -> ElaboratedSharedConfig-              -> ElaboratedInstallPlan-              -> ElaboratedReadyPackage-              -> BuildStatus-              -> IO BuildResult-rebuildTarget verbosity-              distDirLayout@DistDirLayout{distBuildDirectory}-              storeDirLayout-              buildSettings downloadMap-              registerLock cacheLock-              sharedPackageConfig-              plan rpkg@(ReadyPackage pkg)-              pkgBuildStatus =--    -- We rely on the 'BuildStatus' to decide which phase to start from:-    case pkgBuildStatus of-      BuildStatusDownload              -> downloadPhase-      BuildStatusUnpack tarball        -> unpackTarballPhase tarball-      BuildStatusRebuild srcdir status -> rebuildPhase status srcdir--      -- TODO: perhaps re-nest the types to make these impossible-      BuildStatusPreExisting {} -> unexpectedState-      BuildStatusInstalled   {} -> unexpectedState-      BuildStatusUpToDate    {} -> unexpectedState-  where-    unexpectedState = error "rebuildTarget: unexpected package status"--    downloadPhase = do-        downsrcloc <- annotateFailureNoLog DownloadFailed $-                        waitAsyncPackageDownload verbosity downloadMap pkg-        case downsrcloc of-          DownloadedTarball tarball -> unpackTarballPhase tarball-          --TODO: [nice to have] git/darcs repos etc---    unpackTarballPhase tarball =-        withTarballLocalDirectory-          verbosity distDirLayout tarball-          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg)-          (elabBuildStyle pkg)-          (elabPkgDescriptionOverride pkg) $--          case elabBuildStyle pkg of-            BuildAndInstall  -> buildAndInstall-            BuildInplaceOnly -> buildInplace buildStatus-              where-                buildStatus = BuildStatusConfigure MonitorFirstRun--    -- Note that this really is rebuild, not build. It can only happen for-    -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages-    -- would only start from download or unpack phases.-    ---    rebuildPhase buildStatus srcdir =-        assert (elabBuildStyle pkg == BuildInplaceOnly) $--          buildInplace buildStatus srcdir builddir-      where-        builddir = distBuildDirectory-                   (elabDistDirParams sharedPackageConfig pkg)--    buildAndInstall srcdir builddir =-        buildAndInstallUnpackedPackage-          verbosity distDirLayout storeDirLayout-          buildSettings registerLock cacheLock-          sharedPackageConfig-          plan rpkg-          srcdir builddir'-      where-        builddir' = makeRelative srcdir builddir-        --TODO: [nice to have] ^^ do this relative stuff better--    buildInplace buildStatus srcdir builddir =-        --TODO: [nice to have] use a relative build dir rather than absolute-        buildInplaceUnpackedPackage-          verbosity distDirLayout-          buildSettings registerLock cacheLock-          sharedPackageConfig-          plan rpkg-          buildStatus-          srcdir builddir---- TODO: [nice to have] do we need to use a with-style for the temp--- files for downloading http packages, or are we going to cache them--- persistently?---- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the--- packages we have to download and fork off an async action to download them.--- We download them in dependency order so that the one's we'll need--- first are the ones we will start downloading first.------ The body action is passed a map from those packages (identified by their--- location) to a completion var for that package. So the body action should--- lookup the location and use 'waitAsyncPackageDownload' to get the result.----asyncDownloadPackages :: Verbosity-                      -> ((RepoContext -> IO a) -> IO a)-                      -> ElaboratedInstallPlan-                      -> BuildStatusMap-                      -> (AsyncFetchMap -> IO a)-                      -> IO a-asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body-  | null pkgsToDownload = body Map.empty-  | otherwise           = withRepoCtx $ \repoctx ->-                            asyncFetchPackages verbosity repoctx-                                               pkgsToDownload body-  where-    pkgsToDownload =-      ordNub $-      [ elabPkgSourceLocation elab-      | InstallPlan.Configured elab-         <- InstallPlan.reverseTopologicalOrder installPlan-      , let uid = installedUnitId elab-            pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus-      , BuildStatusDownload <- [pkgBuildStatus]-      ]----- | Check if a package needs downloading, and if so expect to find a download--- in progress in the given 'AsyncFetchMap' and wait on it to finish.----waitAsyncPackageDownload :: Verbosity-                         -> AsyncFetchMap-                         -> ElaboratedConfiguredPackage-                         -> IO DownloadedSourceLocation-waitAsyncPackageDownload verbosity downloadMap elab = do-    pkgloc <- waitAsyncFetchPackage verbosity downloadMap-                                    (elabPkgSourceLocation elab)-    case downloadedSourceLocation pkgloc of-      Just loc -> return loc-      Nothing  -> fail "waitAsyncPackageDownload: unexpected source location"--data DownloadedSourceLocation = DownloadedTarball FilePath-                              --TODO: [nice to have] git/darcs repos etc--downloadedSourceLocation :: PackageLocation FilePath-                         -> Maybe DownloadedSourceLocation-downloadedSourceLocation pkgloc =-    case pkgloc of-      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)-      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)-      _                              -> Nothing------- | Ensure that the package is unpacked in an appropriate directory, either--- a temporary one or a persistent one under the shared dist directory.----withTarballLocalDirectory-  :: Verbosity-  -> DistDirLayout-  -> FilePath-  -> PackageId-  -> DistDirParams-  -> BuildStyle-  -> Maybe CabalFileText-  -> (FilePath -> -- Source directory-      FilePath -> -- Build directory-      IO a)-  -> IO a-withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}-                          tarball pkgid dparams buildstyle pkgTextOverride-                          buildPkg  =-      case buildstyle of-        -- In this case we make a temp dir (e.g. tmp/src2345/), unpack-        -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for-        -- compatibility we put the dist dir within it-        -- (i.e. tmp/src2345/foo-1.0/dist/).-        ---        -- Unfortunately, a few custom Setup.hs scripts do not respect-        -- the --builddir flag and always look for it at ./dist/ so-        -- this way we avoid breaking those packages-        BuildAndInstall ->-          let tmpdir = distTempDirectory in-          withTempDirectory verbosity tmpdir "src"   $ \unpackdir -> do-            unpackPackageTarball verbosity tarball unpackdir-                                 pkgid pkgTextOverride-            let srcdir   = unpackdir </> prettyShow pkgid-                builddir = srcdir </> "dist"-            buildPkg srcdir builddir--        -- In this case we make sure the tarball has been unpacked to the-        -- appropriate location under the shared dist dir, and then build it-        -- inplace there-        BuildInplaceOnly -> do-          let srcrootdir = distUnpackedSrcRootDirectory-              srcdir     = distUnpackedSrcDirectory pkgid-              builddir   = distBuildDirectory dparams-          -- TODO: [nice to have] use a proper file monitor rather-          -- than this dir exists test-          exists <- doesDirectoryExist srcdir-          unless exists $ do-            createDirectoryIfMissingVerbose verbosity True srcrootdir-            unpackPackageTarball verbosity tarball srcrootdir-                                 pkgid pkgTextOverride-            moveTarballShippedDistDirectory verbosity distDirLayout-                                            srcrootdir pkgid dparams-          buildPkg srcdir builddir---unpackPackageTarball :: Verbosity -> FilePath -> FilePath-                     -> PackageId -> Maybe CabalFileText-                     -> IO ()-unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =-    --TODO: [nice to have] switch to tar package and catch tar exceptions-    annotateFailureNoLog UnpackFailed $ do--      -- Unpack the tarball-      ---      info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."-      Tar.extractTarGzFile parentdir pkgsubdir tarball--      -- Sanity check-      ---      exists <- doesFileExist cabalFile-      unless exists $-        die' verbosity $-        "Package .cabal file not found in the tarball: " ++ cabalFile--      -- Overwrite the .cabal with the one from the index, when appropriate-      ---      case pkgTextOverride of-        Nothing     -> return ()-        Just pkgtxt -> do-          info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal"-                        ++ " with the latest revision from the index."-          writeFileAtomic cabalFile pkgtxt--  where-    cabalFile = parentdir </> pkgsubdir-                          </> prettyShow pkgname <.> "cabal"-    pkgsubdir = prettyShow pkgid-    pkgname   = packageName pkgid----- | This is a bit of a hacky workaround. A number of packages ship--- pre-processed .hs files in a dist directory inside the tarball. We don't--- use the standard 'dist' location so unless we move this dist dir to the--- right place then we'll miss the shipped pre-procssed files. This hacky--- approach to shipped pre-procssed files ought to be replaced by a proper--- system, though we'll still need to keep this hack for older packages.----moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout-                                -> FilePath -> PackageId -> DistDirParams-                                -> IO ()-moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}-                                parentdir pkgid dparams = do-    distDirExists <- doesDirectoryExist tarballDistDir-    when distDirExists $ do-      debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"-                                   ++ targetDistDir ++ "'"-      --TODO: [nice to have] or perhaps better to copy, and use a file monitor-      renameDirectory tarballDistDir targetDistDir-  where-    tarballDistDir = parentdir </> prettyShow pkgid </> "dist"-    targetDistDir  = distBuildDirectory dparams---buildAndInstallUnpackedPackage :: Verbosity-                               -> DistDirLayout-                               -> StoreDirLayout-                               -> BuildTimeSettings -> Lock -> Lock-                               -> ElaboratedSharedConfig-                               -> ElaboratedInstallPlan-                               -> ElaboratedReadyPackage-                               -> FilePath -> FilePath-                               -> IO BuildResult-buildAndInstallUnpackedPackage verbosity-                               distDirLayout@DistDirLayout{distTempDirectory}-                               storeDirLayout@StoreDirLayout {-                                 storePackageDBStack-                               }-                               BuildTimeSettings {-                                 buildSettingNumJobs,-                                 buildSettingLogFile-                               }-                               registerLock cacheLock-                               pkgshared@ElaboratedSharedConfig {-                                 pkgConfigPlatform      = platform,-                                 pkgConfigCompiler      = compiler,-                                 pkgConfigCompilerProgs = progdb-                               }-                               plan rpkg@(ReadyPackage pkg)-                               srcdir builddir = do--    createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)-    initLogFile--    --TODO: [code cleanup] deal consistently with talking to older-    --      Setup.hs versions, much like we do for ghc, with a proper-    --      options type and rendering step which will also let us-    --      call directly into the lib, rather than always going via-    --      the lib's command line interface, which would also allow-    --      passing data like installed packages, compiler, and-    --      program db for a quicker configure.--    --TODO: [required feature] docs and tests-    --TODO: [required feature] sudo re-exec--    -- Configure phase-    noticeProgress ProgressStarting--    annotateFailure mlogFile ConfigureFailed $-      setup' configureCommand configureFlags configureArgs--    -- Build phase-    noticeProgress ProgressBuilding--    annotateFailure mlogFile BuildFailed $-      setup buildCommand buildFlags--    -- Haddock phase-    whenHaddock $ do-      noticeProgress ProgressHaddock-      annotateFailureNoLog HaddocksFailed $-        setup haddockCommand haddockFlags--    -- Install phase-    noticeProgress ProgressInstalling-    annotateFailure mlogFile InstallFailed $ do--      let copyPkgFiles tmpDir = do-            let tmpDirNormalised = normalise tmpDir-            setup Cabal.copyCommand (copyFlags tmpDirNormalised)-            -- Note that the copy command has put the files into-            -- @$tmpDir/$prefix@ so we need to return this dir so-            -- the store knows which dir will be the final store entry.-            let prefix   = normalise $-                           dropDrive (InstallDirs.prefix (elabInstallDirs pkg))-                entryDir = tmpDirNormalised </> prefix--            -- if there weren't anything to build, it might be that directory is not created-            -- the @setup Cabal.copyCommand@ above might do nothing.-            -- https://github.com/haskell/cabal/issues/4130-            createDirectoryIfMissingVerbose verbosity True entryDir--            LBS.writeFile-              (entryDir </> "cabal-hash.txt")-              (renderPackageHashInputs (packageHashInputs pkgshared pkg))--            -- Ensure that there are no files in `tmpDir`, that are-            -- not in `entryDir`. While this breaks the-            -- prefix-relocatable property of the libraries, it is-            -- necessary on macOS to stay under the load command limit-            -- of the macOS mach-o linker. See also-            -- @PackageHash.hashedInstalledPackageIdVeryShort@.-            ---            -- We also normalise paths to ensure that there are no-            -- different representations for the same path. Like / and-            -- \\ on windows under msys.-            otherFiles <- filter (not . isPrefixOf entryDir) <$>-                          listFilesRecursive tmpDirNormalised-            -- Here's where we could keep track of the installed files-            -- ourselves if we wanted to by making a manifest of the-            -- files in the tmp dir.-            return (entryDir, otherFiles)-            where-              listFilesRecursive :: FilePath -> IO [FilePath]-              listFilesRecursive path = do-                files <- fmap (path </>) <$> (listDirectory path)-                allFiles <- for files $ \file -> do-                  isDir <- doesDirectoryExist file-                  if isDir-                    then listFilesRecursive file-                    else return [file]-                return (concat allFiles)--          registerPkg-            | not (elabRequiresRegistration pkg) =-              debug verbosity $-                "registerPkg: elab does NOT require registration for "-                ++ prettyShow uid-            | otherwise = do-            -- We register ourselves rather than via Setup.hs. We need to-            -- grab and modify the InstalledPackageInfo. We decide what-            -- the installed package id is, not the build system.-            ipkg0 <- generateInstalledPackageInfo-            let ipkg = ipkg0 { Installed.installedUnitId = uid }-            assert (   elabRegisterPackageDBStack pkg-                    == storePackageDBStack compid) (return ())-            criticalSection registerLock $-              Cabal.registerPackage-                verbosity compiler progdb-                (storePackageDBStack compid) ipkg-                Cabal.defaultRegisterOptions {-                  Cabal.registerMultiInstance      = True,-                  Cabal.registerSuppressFilesCheck = True-                }---      -- Actual installation-      void $ newStoreEntry verbosity storeDirLayout-                           compid uid-                           copyPkgFiles registerPkg--    --TODO: [nice to have] we currently rely on Setup.hs copy to do the right-    -- thing. Although we do copy into an image dir and do the move into the-    -- final location ourselves, perhaps we ought to do some sanity checks on-    -- the image dir first.--    -- TODO: [required eventually] note that for nix-style-    -- installations it is not necessary to do the-    -- 'withWin32SelfUpgrade' dance, but it would be necessary for a-    -- shared bin dir.--    --TODO: [required feature] docs and test phases-    let docsResult  = DocsNotTried-        testsResult = TestsNotTried--    noticeProgress ProgressCompleted--    return BuildResult {-       buildResultDocs    = docsResult,-       buildResultTests   = testsResult,-       buildResultLogFile = mlogFile-    }--  where-    pkgid  = packageId rpkg-    uid    = installedUnitId rpkg-    compid = compilerId compiler--    dispname = case elabPkgOrComp pkg of-        ElabPackage _ -> prettyShow pkgid-            ++ " (all, legacy fallback)"-        ElabComponent comp -> prettyShow pkgid-            ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")"--    noticeProgress phase = when isParallelBuild $-        progressMessage verbosity phase dispname--    isParallelBuild = buildSettingNumJobs >= 2--    whenHaddock action-      | hasValidHaddockTargets pkg = action-      | otherwise                  = return ()--    configureCommand = Cabal.configureCommand defaultProgramDb-    configureFlags v = flip filterConfigureFlags v $-                       setupHsConfigureFlags rpkg pkgshared-                                             verbosity builddir-    configureArgs _  = setupHsConfigureArgs pkg--    buildCommand     = Cabal.buildCommand defaultProgramDb-    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir--    haddockCommand   = Cabal.haddockCommand-    haddockFlags _   = setupHsHaddockFlags pkg pkgshared-                                           verbosity builddir--    generateInstalledPackageInfo :: IO InstalledPackageInfo-    generateInstalledPackageInfo =-      withTempInstalledPackageInfoFile-        verbosity distTempDirectory $ \pkgConfDest -> do-        let registerFlags _ = setupHsRegisterFlags-                                pkg pkgshared-                                verbosity builddir-                                pkgConfDest-        setup Cabal.registerCommand registerFlags--    copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity-                                           builddir destdir--    scriptOptions = setupHsScriptOptions rpkg plan pkgshared-                                         distDirLayout srcdir builddir-                                         isParallelBuild cacheLock--    setup :: CommandUI flags -> (Version -> flags) -> IO ()-    setup cmd flags = setup' cmd flags (const [])--    setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String])-           -> IO ()-    setup' cmd flags args =-      withLogging $ \mLogFileHandle ->-        setupWrapper-          verbosity-          scriptOptions-            { useLoggingHandle     = mLogFileHandle-            , useExtraEnvOverrides = dataDirsEnvironmentForPlan-                                     distDirLayout plan }-          (Just (elabPkgDescription pkg))-          cmd flags args--    mlogFile :: Maybe FilePath-    mlogFile =-      case buildSettingLogFile of-        Nothing        -> Nothing-        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)--    initLogFile =-      case mlogFile of-        Nothing      -> return ()-        Just logFile -> do-          createDirectoryIfMissing True (takeDirectory logFile)-          exists <- doesFileExist logFile-          when exists $ removeFile logFile--    withLogging action =-      case mlogFile of-        Nothing      -> action Nothing-        Just logFile -> withFile logFile AppendMode (action . Just)---hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool-hasValidHaddockTargets ElaboratedConfiguredPackage{..}-  | not elabBuildHaddocks = False-  | otherwise             = any componentHasHaddocks components-  where-    components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets-              ++ maybeToList elabReplTarget ++ elabHaddockTargets--    componentHasHaddocks :: ComponentTarget -> Bool-    componentHasHaddocks (ComponentTarget name _) =-      case name of-        CLibName LMainLibName    ->                           hasHaddocks-        CLibName (LSubLibName _) -> elabHaddockInternal    && hasHaddocks-        CFLibName              _ -> elabHaddockForeignLibs && hasHaddocks-        CExeName               _ -> elabHaddockExecutables && hasHaddocks-        CTestName              _ -> elabHaddockTestSuites  && hasHaddocks-        CBenchName             _ -> elabHaddockBenchmarks  && hasHaddocks-      where-        hasHaddocks = not (null (elabPkgDescription ^. componentModules name))---buildInplaceUnpackedPackage :: Verbosity-                            -> DistDirLayout-                            -> BuildTimeSettings -> Lock -> Lock-                            -> ElaboratedSharedConfig-                            -> ElaboratedInstallPlan-                            -> ElaboratedReadyPackage-                            -> BuildStatusRebuild-                            -> FilePath -> FilePath-                            -> IO BuildResult-buildInplaceUnpackedPackage verbosity-                            distDirLayout@DistDirLayout {-                              distTempDirectory,-                              distPackageCacheDirectory,-                              distDirectory-                            }-                            BuildTimeSettings{buildSettingNumJobs}-                            registerLock cacheLock-                            pkgshared@ElaboratedSharedConfig {-                              pkgConfigCompiler      = compiler,-                              pkgConfigCompilerProgs = progdb-                            }-                            plan-                            rpkg@(ReadyPackage pkg)-                            buildStatus-                            srcdir builddir = do--        --TODO: [code cleanup] there is duplication between the-        --      distdirlayout and the builddir here builddir is not-        --      enough, we also need the per-package cachedir-        createDirectoryIfMissingVerbose verbosity True builddir-        createDirectoryIfMissingVerbose verbosity True-          (distPackageCacheDirectory dparams)--        -- Configure phase-        ---        whenReConfigure $ do-          annotateFailureNoLog ConfigureFailed $-            setup configureCommand configureFlags configureArgs-          invalidatePackageRegFileMonitor packageFileMonitor-          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg--        -- Build phase-        ---        let docsResult  = DocsNotTried-            testsResult = TestsNotTried--            buildResult :: BuildResultMisc-            buildResult = (docsResult, testsResult)--        whenRebuild $ do-          timestamp <- beginUpdateFileMonitor-          annotateFailureNoLog BuildFailed $-            setup buildCommand buildFlags buildArgs--          let listSimple =-                execRebuild srcdir (needElaboratedConfiguredPackage pkg)-              listSdist =-                fmap (map monitorFileHashed) $-                    allPackageSourceFiles verbosity srcdir-              ifNullThen m m' = do xs <- m-                                   if null xs then m' else return xs-          monitors <- case PD.buildType (elabPkgDescription pkg) of-            Simple -> listSimple-            -- If a Custom setup was used, AND the Cabal is recent-            -- enough to have sdist --list-sources, use that to-            -- determine the files that we need to track.  This can-            -- cause unnecessary rebuilding (for example, if README-            -- is edited, we will try to rebuild) but there isn't-            -- a more accurate Custom interface we can use to get-            -- this info.  We prefer not to use listSimple here-            -- as it can miss extra source files that are considered-            -- by the Custom setup.-            _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17]-              -- However, sometimes sdist --list-sources will fail-              -- and return an empty list.  In that case, fall-              -- back on the (inaccurate) simple tracking.-              -> listSdist `ifNullThen` listSimple-              | otherwise-              -> listSimple--          let dep_monitors = map monitorFileHashed-                           $ elabInplaceDependencyBuildCacheFiles-                                distDirLayout pkgshared plan pkg-          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp-                                        pkg buildStatus-                                        (monitors ++ dep_monitors) buildResult--        -- PURPOSELY omitted: no copy!--        whenReRegister $ annotateFailureNoLog InstallFailed $ do-          -- Register locally-          mipkg <- if elabRequiresRegistration pkg-            then do-                ipkg0 <- generateInstalledPackageInfo-                -- We register ourselves rather than via Setup.hs. We need to-                -- grab and modify the InstalledPackageInfo. We decide what-                -- the installed package id is, not the build system.-                let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }-                criticalSection registerLock $-                    Cabal.registerPackage verbosity compiler progdb-                                          (elabRegisterPackageDBStack pkg)-                                          ipkg Cabal.defaultRegisterOptions-                return (Just ipkg)--           else return Nothing--          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg--        whenTest $ do-          annotateFailureNoLog TestsFailed $-            setup testCommand testFlags testArgs--        whenBench $-          annotateFailureNoLog BenchFailed $-            setup benchCommand benchFlags benchArgs--        -- Repl phase-        ---        whenRepl $-          annotateFailureNoLog ReplFailed $-          setupInteractive replCommand replFlags replArgs--        -- Haddock phase-        whenHaddock $-          annotateFailureNoLog HaddocksFailed $ do-            setup haddockCommand haddockFlags haddockArgs-            let haddockTarget = elabHaddockForHackage pkg-            when (haddockTarget == Cabal.ForHackage) $ do-              let dest = distDirectory </> name <.> "tar.gz"-                  name = haddockDirName haddockTarget (elabPkgDescription pkg)-                  docDir = distBuildDirectory distDirLayout dparams-                           </> "doc" </> "html"-              Tar.createTarGzFile dest docDir name-              notice verbosity $ "Documentation tarball created: " ++ dest--        return BuildResult {-          buildResultDocs    = docsResult,-          buildResultTests   = testsResult,-          buildResultLogFile = Nothing-        }--  where-    ipkgid  = installedUnitId pkg-    dparams = elabDistDirParams pkgshared pkg--    isParallelBuild = buildSettingNumJobs >= 2--    packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams--    whenReConfigure action = case buildStatus of-      BuildStatusConfigure _ -> action-      _                      -> return ()--    whenRebuild action-      | null (elabBuildTargets pkg)-      -- NB: we have to build the test/bench suite!-      , null (elabTestTargets pkg)-      , null (elabBenchTargets pkg) = return ()-      | otherwise                   = action--    whenTest action-      | null (elabTestTargets pkg) = return ()-      | otherwise                  = action--    whenBench action-      | null (elabBenchTargets pkg) = return ()-      | otherwise                   = action--    whenRepl action-      | isNothing (elabReplTarget pkg) = return ()-      | otherwise                     = action--    whenHaddock action-      | hasValidHaddockTargets pkg = action-      | otherwise                  = return ()--    whenReRegister  action-      = case buildStatus of-          -- We registered the package already-          BuildStatusBuild (Just _) _     ->-            info verbosity "whenReRegister: previously registered"-          -- There is nothing to register-          _ | null (elabBuildTargets pkg) ->-              info verbosity "whenReRegister: nothing to register"-            | otherwise                   -> action--    configureCommand = Cabal.configureCommand defaultProgramDb-    configureFlags v = flip filterConfigureFlags v $-                       setupHsConfigureFlags rpkg pkgshared-                                             verbosity builddir-    configureArgs _  = setupHsConfigureArgs pkg--    buildCommand     = Cabal.buildCommand defaultProgramDb-    buildFlags   _   = setupHsBuildFlags pkg pkgshared-                                         verbosity builddir-    buildArgs     _  = setupHsBuildArgs  pkg--    testCommand      = Cabal.testCommand -- defaultProgramDb-    testFlags      v = flip filterTestFlags v $-                       setupHsTestFlags pkg pkgshared-                                         verbosity builddir-    testArgs      _  = setupHsTestArgs  pkg--    benchCommand     = Cabal.benchmarkCommand-    benchFlags    _  = setupHsBenchFlags pkg pkgshared-                                          verbosity builddir-    benchArgs     _  = setupHsBenchArgs  pkg--    replCommand      = Cabal.replCommand defaultProgramDb-    replFlags _      = setupHsReplFlags pkg pkgshared-                                        verbosity builddir-    replArgs _       = setupHsReplArgs  pkg--    haddockCommand   = Cabal.haddockCommand-    haddockFlags v   = flip filterHaddockFlags v $-                       setupHsHaddockFlags pkg pkgshared-                                           verbosity builddir-    haddockArgs    v = flip filterHaddockArgs v $-                       setupHsHaddockArgs pkg--    scriptOptions    = setupHsScriptOptions rpkg plan pkgshared-                                            distDirLayout srcdir builddir-                                            isParallelBuild cacheLock--    setupInteractive :: CommandUI flags-                     -> (Version -> flags) -> (Version -> [String]) -> IO ()-    setupInteractive cmd flags args =-      setupWrapper verbosity-                   scriptOptions { isInteractive = True }-                   (Just (elabPkgDescription pkg))-                   cmd flags args--    setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])-          -> IO ()-    setup cmd flags args =-      setupWrapper verbosity-                   scriptOptions-                   (Just (elabPkgDescription pkg))-                   cmd flags args--    generateInstalledPackageInfo :: IO InstalledPackageInfo-    generateInstalledPackageInfo =-      withTempInstalledPackageInfoFile-        verbosity distTempDirectory $ \pkgConfDest -> do-        let registerFlags _ = setupHsRegisterFlags-                                pkg pkgshared-                                verbosity builddir-                                pkgConfDest-        setup Cabal.registerCommand registerFlags (const [])--withTempInstalledPackageInfoFile :: Verbosity -> FilePath-                                  -> (FilePath -> IO ())-                                  -> IO InstalledPackageInfo-withTempInstalledPackageInfoFile verbosity tempdir action =-    withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do-      -- make absolute since @action@ will often change directory-      abs_dir <- canonicalizePath dir--      let pkgConfDest = abs_dir </> "pkgConf"-      action pkgConfDest--      readPkgConf "." pkgConfDest-  where-    pkgConfParseFailed :: String -> IO a-    pkgConfParseFailed perror =-      die' verbosity $-      "Couldn't parse the output of 'setup register --gen-pkg-config':"-      ++ show perror--    readPkgConf pkgConfDir pkgConfFile = do-      pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)-      (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of-        Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors-        Right (warns, ipkg) -> return (warns, ipkg)--      unless (null warns) $-        warn verbosity $ unlines warns--      return ipkg------------------------------------------------------------------------------------ * Utilities---------------------------------------------------------------------------------annotateFailureNoLog :: (SomeException -> BuildFailureReason)-                     -> IO a -> IO a-annotateFailureNoLog annotate action =-  annotateFailure Nothing annotate action--annotateFailure :: Maybe FilePath-                -> (SomeException -> BuildFailureReason)-                -> IO a -> IO a-annotateFailure mlogFile annotate action =-  action `catches`-    -- It's not just IOException and ExitCode we have to deal with, there's-    -- lots, including exceptions from the hackage-security and tar packages.-    -- So we take the strategy of catching everything except async exceptions.-    [-#if MIN_VERSION_base(4,7,0)-      Handler $ \async -> throwIO (async :: SomeAsyncException)-#else-      Handler $ \async -> throwIO (async :: AsyncException)-#endif-    , Handler $ \other -> handler (other :: SomeException)-    ]-  where-    handler :: Exception e => e -> IO a-    handler = throwIO . BuildFailure mlogFile . annotate . toException
− Distribution/Client/ProjectBuilding/Types.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | Types for the "Distribution.Client.ProjectBuilding"------ Moved out to avoid module cycles.----module Distribution.Client.ProjectBuilding.Types (-    -- * Pre-build status-    BuildStatusMap,-    BuildStatus(..),-    buildStatusRequiresBuild,-    buildStatusToString,-    BuildStatusRebuild(..),-    BuildReason(..),-    MonitorChangedReason(..),--    -- * Build outcomes-    BuildOutcomes,-    BuildOutcome,-    BuildResult(..),-    BuildFailure(..),-    BuildFailureReason(..),-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.Types          (DocsResult, TestsResult)-import Distribution.Client.FileMonitor    (MonitorChangedReason(..))--import Distribution.Package               (UnitId, PackageId)-import Distribution.InstalledPackageInfo  (InstalledPackageInfo)-import Distribution.Simple.LocalBuildInfo (ComponentName)------------------------------------------------------------------------------------ Pre-build status: result of the dry run------- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.------ This is used as the result of the dry-run of building an install plan.----type BuildStatusMap = Map UnitId BuildStatus---- | The build status for an individual package is the state that the--- package is in /prior/ to initiating a (re)build.------ This should not be confused with a 'BuildResult' which is the result--- /after/ successfully building a package.------ It serves two purposes:------  * For dry-run output, it lets us explain to the user if and why a package---    is going to be (re)built.------  * It tell us what step to start or resume building from, and carries---    enough information for us to be able to do so.----data BuildStatus =--     -- | The package is in the 'InstallPlan.PreExisting' state, so does not-     --   need building.-     BuildStatusPreExisting--     -- | The package is in the 'InstallPlan.Installed' state, so does not-     --   need building.-   | BuildStatusInstalled--     -- | The package has not been downloaded yet, so it will have to be-     --   downloaded, unpacked and built.-   | BuildStatusDownload--     -- | The package has not been unpacked yet, so it will have to be-     --   unpacked and built.-   | BuildStatusUnpack FilePath--     -- | The package exists in a local dir already, and just needs building-     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style-     --   packages.-   | BuildStatusRebuild FilePath BuildStatusRebuild--     -- | The package exists in a local dir already, and is fully up to date.-     --   So this package can be put into the 'InstallPlan.Installed' state-     --   and it does not need to be built.-   | BuildStatusUpToDate BuildResult----- | Which 'BuildStatus' values indicate we'll have to do some build work of--- some sort. In particular we use this as part of checking if any of a--- package's deps have changed.----buildStatusRequiresBuild :: BuildStatus -> Bool-buildStatusRequiresBuild BuildStatusPreExisting = False-buildStatusRequiresBuild BuildStatusInstalled   = False-buildStatusRequiresBuild BuildStatusUpToDate {} = False-buildStatusRequiresBuild _                      = True---- | This is primarily here for debugging. It's not actually used anywhere.----buildStatusToString :: BuildStatus -> String-buildStatusToString BuildStatusPreExisting    = "BuildStatusPreExisting"-buildStatusToString BuildStatusInstalled      = "BuildStatusInstalled"-buildStatusToString BuildStatusDownload       = "BuildStatusDownload"-buildStatusToString (BuildStatusUnpack fp)    = "BuildStatusUnpack " ++ show fp-buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp-buildStatusToString (BuildStatusUpToDate _)   = "BuildStatusUpToDate"----- | For a package that is going to be built or rebuilt, the state it's in now.------ So again, this tells us why a package needs to be rebuilt and what build--- phases need to be run. The 'MonitorChangedReason' gives us details like--- which file changed, which is mainly for high verbosity debug output.----data BuildStatusRebuild =--     -- | The package configuration changed, so the configure and build phases-     --   needs to be (re)run.-     BuildStatusConfigure (MonitorChangedReason ())--     -- | The configuration has not changed but the build phase needs to be-     -- rerun. We record the reason the (re)build is needed.-     ---     -- The optional registration info here tells us if we've registered the-     -- package already, or if we still need to do that after building.-     -- @Just Nothing@ indicates that we know that no registration is-     -- necessary (e.g., executable.)-     ---   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason--data BuildReason =-     -- | The dependencies of this package have been (re)built so the build-     -- phase needs to be rerun.-     ---     BuildReasonDepsRebuilt--     -- | Changes in files within the package (or first run or corrupt cache)-   | BuildReasonFilesChanged (MonitorChangedReason ())--     -- | An important special case is that no files have changed but the-     -- set of components the /user asked to build/ has changed. We track the-     -- set of components /we have built/, which of course only grows (until-     -- some other change resets it).-     ---     -- The @Set 'ComponentName'@ is the set of components we have built-     -- previously. When we update the monitor we take the union of the ones-     -- we have built previously with the ones the user has asked for this-     -- time and save those. See 'updatePackageBuildFileMonitor'.-     ---   | BuildReasonExtraTargets (Set ComponentName)--     -- | Although we're not going to build any additional targets as a whole,-     -- we're going to build some part of a component or run a repl or any-     -- other action that does not result in additional persistent artifacts.-     ---   | BuildReasonEphemeralTargets------------------------------------------------------------------------------------ Build outcomes: result of the build------- | A summary of the outcome for building a whole set of packages.----type BuildOutcomes = Map UnitId BuildOutcome---- | A summary of the outcome for building a single package: either success--- or failure.----type BuildOutcome  = Either BuildFailure BuildResult---- | Information arising from successfully building a single package.----data BuildResult = BuildResult {-       buildResultDocs    :: DocsResult,-       buildResultTests   :: TestsResult,-       buildResultLogFile :: Maybe FilePath-     }-  deriving Show---- | Information arising from the failure to build a single package.----data BuildFailure = BuildFailure {-       buildFailureLogFile :: Maybe FilePath,-       buildFailureReason  :: BuildFailureReason-     }-  deriving (Show, Typeable)--instance Exception BuildFailure---- | Detail on the reason that a package failed to build.----data BuildFailureReason = DependentFailed PackageId-                        | DownloadFailed  SomeException-                        | UnpackFailed    SomeException-                        | ConfigureFailed SomeException-                        | BuildFailed     SomeException-                        | ReplFailed      SomeException-                        | HaddocksFailed  SomeException-                        | TestsFailed     SomeException-                        | BenchFailed     SomeException-                        | InstallFailed   SomeException-  deriving Show
− Distribution/Client/ProjectConfig.hs 
@@ -1,1464 +0,0 @@-{-# LANGUAGE BangPatterns       #-}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE NamedFieldPuns     #-}-{-# LANGUAGE RecordWildCards    #-}---- | Handling project configuration.----module Distribution.Client.ProjectConfig (--    -- * Types for project config-    ProjectConfig(..),-    ProjectConfigBuildOnly(..),-    ProjectConfigShared(..),-    ProjectConfigProvenance(..),-    PackageConfig(..),-    MapLast(..),-    MapMappend(..),--    -- * Project root-    findProjectRoot,-    ProjectRoot(..),-    BadProjectRoot(..),--    -- * Project config files-    readProjectConfig,-    readGlobalConfig,-    readProjectLocalFreezeConfig,-    withProjectOrGlobalConfig,-    writeProjectLocalExtraConfig,-    writeProjectLocalFreezeConfig,-    writeProjectConfigFile,-    commandLineFlagsToProjectConfig,--    -- * Packages within projects-    ProjectPackageLocation(..),-    BadPackageLocations(..),-    BadPackageLocation(..),-    BadPackageLocationMatch(..),-    findProjectPackages,-    fetchAndReadSourcePackages,--    -- * Resolving configuration-    lookupLocalPackageConfig,-    projectConfigWithBuilderRepoContext,-    projectConfigWithSolverRepoContext,-    SolverSettings(..),-    resolveSolverSettings,-    BuildTimeSettings(..),-    resolveBuildTimeSettings,--    -- * Checking configuration-    checkBadPerPackageCompilerPaths,-    BadPerPackageCompilerPaths(..)-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.ProjectConfig.Types-import Distribution.Client.ProjectConfig.Legacy-import Distribution.Client.RebuildMonad-import Distribution.Client.Glob-         ( isTrivialFilePathGlob )-import Distribution.Client.VCS-         ( validateSourceRepos, SourceRepoProblem(..)-         , VCS(..), knownVCSs, configureVCS, syncSourceRepos )--import Distribution.Client.Types-import Distribution.Client.DistDirLayout-         ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) )-import Distribution.Client.GlobalFlags-         ( RepoContext(..), withRepoContext' )-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import Distribution.Client.Config-         ( loadConfig, getConfigFilePath )-import Distribution.Client.HttpUtils-         ( HttpTransport, configureTransport, transportCheckHttps-         , downloadURI )-import Distribution.Client.Utils.Parsec (renderParseError)--import Distribution.Solver.Types.SourcePackage-import Distribution.Solver.Types.Settings-import Distribution.Solver.Types.PackageConstraint-         ( PackageProperty(..) )--import Distribution.Package-         ( PackageName, PackageId, UnitId, packageId )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint(..) )-import Distribution.System-         ( Platform )-import Distribution.Types.GenericPackageDescription-         ( GenericPackageDescription )-import Distribution.PackageDescription.Parsec-         ( parseGenericPackageDescription )-import Distribution.Fields-         ( runParseResult, PError, PWarning, showPWarning)-import Distribution.Types.SourceRepo-         ( RepoType(..) )-import Distribution.Client.Types.SourceRepo-         ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut )-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo )-import Distribution.Simple.Program-         ( ConfiguredProgram(..) )-import Distribution.Simple.Setup-         ( Flag(Flag), toFlag, flagToMaybe, flagToList-         , fromFlag, fromFlagOrDefault )-import Distribution.Client.Setup-         ( defaultSolver, defaultMaxBackjumps )-import Distribution.Simple.InstallDirs-         ( PathTemplate, fromPathTemplate-         , toPathTemplate, substPathTemplate, initialPathTemplateEnv )-import Distribution.Simple.Utils-         ( die', warn, notice, info, createDirectoryIfMissingVerbose )-import Distribution.Client.Utils-         ( determineNumJobs )-import Distribution.Utils.NubList-         ( fromNubList )-import Distribution.Verbosity-         ( modifyVerbosity, verbose )-import Distribution.Version-         ( Version )-import qualified Distribution.Deprecated.ParseUtils as OldParser-         ( ParseResult(..), locatedErrorMsg, showPWarning )-import Distribution.Client.SrcDist-         ( packageDirToSdist )--import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Distribution.Client.Tar as Tar-import qualified Distribution.Client.GZipUtils as GZipUtils--import Control.Monad.Trans (liftIO)-import qualified Data.ByteString       as BS-import qualified Data.ByteString.Lazy  as LBS-import qualified Data.Map as Map-import qualified Data.List.NonEmpty as NE-import qualified Data.Set as Set-import qualified Data.Hashable as Hashable-import Numeric (showHex)--import System.FilePath hiding (combine)-import System.IO-         ( withBinaryFile, IOMode(ReadMode) )-import System.Directory-import Network.URI-         ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString )---------------------------------------------- Resolving configuration to settings------- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific--- 'PackageName'. This returns the configuration that applies to all local--- packages plus any package-specific configuration for this package.----lookupLocalPackageConfig-  :: (Semigroup a, Monoid a)-  => (PackageConfig -> a) -> ProjectConfig -> PackageName-  -> a-lookupLocalPackageConfig field ProjectConfig {-                           projectConfigLocalPackages,-                           projectConfigSpecificPackage-                         } pkgname =-    field projectConfigLocalPackages- <> maybe mempty field-          (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))----- | Use a 'RepoContext' based on the 'BuildTimeSettings'.----projectConfigWithBuilderRepoContext :: Verbosity-                                    -> BuildTimeSettings-                                    -> (RepoContext -> IO a) -> IO a-projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} =-    withRepoContext'-      verbosity-      buildSettingRemoteRepos-      buildSettingLocalNoIndexRepos-      buildSettingCacheDir-      buildSettingHttpTransport-      (Just buildSettingIgnoreExpiry)-      buildSettingProgPathExtra----- | Use a 'RepoContext', but only for the solver. The solver does not use the--- full facilities of the 'RepoContext' so we can get away with making one--- that doesn't have an http transport. And that avoids having to have access--- to the 'BuildTimeSettings'----projectConfigWithSolverRepoContext-  :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly-  -> (RepoContext -> IO a)-  -> IO a-projectConfigWithSolverRepoContext verbosity-                                   ProjectConfigShared{..}-                                   ProjectConfigBuildOnly{..} =-    withRepoContext'-      verbosity-      (fromNubList projectConfigRemoteRepos)-      (fromNubList projectConfigLocalNoIndexRepos)-      (fromFlagOrDefault-                   (error-                    "projectConfigWithSolverRepoContext: projectConfigCacheDir")-                   projectConfigCacheDir)-      (flagToMaybe projectConfigHttpTransport)-      (flagToMaybe projectConfigIgnoreExpiry)-      (fromNubList projectConfigProgPathExtra)----- | Resolve the project configuration, with all its optional fields, into--- 'SolverSettings' with no optional fields (by applying defaults).----resolveSolverSettings :: ProjectConfig -> SolverSettings-resolveSolverSettings ProjectConfig{-                        projectConfigShared,-                        projectConfigLocalPackages,-                        projectConfigSpecificPackage-                      } =-    SolverSettings {..}-  where-    --TODO: [required eventually] some of these settings need validation, e.g.-    -- the flag assignments need checking.-    solverSettingRemoteRepos       = fromNubList projectConfigRemoteRepos-    solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos-    solverSettingConstraints       = projectConfigConstraints-    solverSettingPreferences       = projectConfigPreferences-    solverSettingFlagAssignment    = packageConfigFlagAssignment projectConfigLocalPackages-    solverSettingFlagAssignments   = fmap packageConfigFlagAssignment-                                          (getMapMappend projectConfigSpecificPackage)-    solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion-    solverSettingSolver            = fromFlag projectConfigSolver-    solverSettingAllowOlder        = fromMaybe mempty projectConfigAllowOlder-    solverSettingAllowNewer        = fromMaybe mempty projectConfigAllowNewer-    solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of-                                       n | n < 0     -> Nothing-                                         | otherwise -> Just n-    solverSettingReorderGoals      = fromFlag projectConfigReorderGoals-    solverSettingCountConflicts    = fromFlag projectConfigCountConflicts-    solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts-    solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet-    solverSettingStrongFlags       = fromFlag projectConfigStrongFlags-    solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls-    solverSettingOnlyConstrained   = fromFlag projectConfigOnlyConstrained-    solverSettingIndexState        = flagToMaybe projectConfigIndexState-    solverSettingActiveRepos       = flagToMaybe projectConfigActiveRepos-    solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals-  --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs-  --solverSettingReinstall         = fromFlag projectConfigReinstall-  --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls-  --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall-  --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps--    ProjectConfigShared {..} = defaults <> projectConfigShared--    defaults = mempty {-       projectConfigSolver            = Flag defaultSolver,-       projectConfigAllowOlder        = Just (AllowOlder mempty),-       projectConfigAllowNewer        = Just (AllowNewer mempty),-       projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,-       projectConfigReorderGoals      = Flag (ReorderGoals False),-       projectConfigCountConflicts    = Flag (CountConflicts True),-       projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True),-       projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False),-       projectConfigStrongFlags       = Flag (StrongFlags False),-       projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False),-       projectConfigOnlyConstrained   = Flag OnlyConstrainedNone,-       projectConfigIndependentGoals  = Flag (IndependentGoals False)-     --projectConfigShadowPkgs        = Flag False,-     --projectConfigReinstall         = Flag False,-     --projectConfigAvoidReinstalls   = Flag False,-     --projectConfigOverrideReinstall = Flag False,-     --projectConfigUpgradeDeps       = Flag False-    }----- | Resolve the project configuration, with all its optional fields, into--- 'BuildTimeSettings' with no optional fields (by applying defaults).----resolveBuildTimeSettings :: Verbosity-                         -> CabalDirLayout-                         -> ProjectConfig-                         -> BuildTimeSettings-resolveBuildTimeSettings verbosity-                         CabalDirLayout {-                           cabalLogsDirectory-                         }-                         ProjectConfig {-                           projectConfigShared = ProjectConfigShared {-                             projectConfigRemoteRepos,-                             projectConfigLocalNoIndexRepos,-                             projectConfigProgPathExtra-                           },-                           projectConfigBuildOnly-                         } =-    BuildTimeSettings {..}-  where-    buildSettingDryRun        = fromFlag    projectConfigDryRun-    buildSettingOnlyDeps      = fromFlag    projectConfigOnlyDeps-    buildSettingSummaryFile   = fromNubList projectConfigSummaryFile-    --buildSettingLogFile       -- defined below, more complicated-    --buildSettingLogVerbosity  -- defined below, more complicated-    buildSettingBuildReports  = fromFlag    projectConfigBuildReports-    buildSettingSymlinkBinDir = flagToList  projectConfigSymlinkBinDir-    buildSettingOneShot       = fromFlag    projectConfigOneShot-    buildSettingNumJobs       = determineNumJobs projectConfigNumJobs-    buildSettingKeepGoing     = fromFlag    projectConfigKeepGoing-    buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode-    buildSettingKeepTempFiles = fromFlag    projectConfigKeepTempFiles-    buildSettingRemoteRepos   = fromNubList projectConfigRemoteRepos-    buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos-    buildSettingCacheDir      = fromFlag    projectConfigCacheDir-    buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport-    buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry-    buildSettingReportPlanningFailure-                              = fromFlag projectConfigReportPlanningFailure-    buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra--    ProjectConfigBuildOnly{..} = defaults-                              <> projectConfigBuildOnly--    defaults = mempty {-      projectConfigDryRun                = toFlag False,-      projectConfigOnlyDeps              = toFlag False,-      projectConfigBuildReports          = toFlag NoReports,-      projectConfigReportPlanningFailure = toFlag False,-      projectConfigKeepGoing             = toFlag False,-      projectConfigOneShot               = toFlag False,-      projectConfigOfflineMode           = toFlag False,-      projectConfigKeepTempFiles         = toFlag False,-      projectConfigIgnoreExpiry          = toFlag False-    }--    -- The logging logic: what log file to use and what verbosity.-    ---    -- If the user has specified --remote-build-reporting=detailed, use the-    -- default log file location. If the --build-log option is set, use the-    -- provided location. Otherwise don't use logging, unless building in-    -- parallel (in which case the default location is used).-    ---    buildSettingLogFile :: Maybe (Compiler -> Platform-                               -> PackageId -> UnitId -> FilePath)-    buildSettingLogFile-      | useDefaultTemplate = Just (substLogFileName defaultTemplate)-      | otherwise          = fmap  substLogFileName givenTemplate--    defaultTemplate = toPathTemplate $-                        cabalLogsDirectory </>-                        "$compiler" </> "$libname" <.> "log"-    givenTemplate   = flagToMaybe projectConfigLogFile--    useDefaultTemplate-      | buildSettingBuildReports == DetailedReports = True-      | isJust givenTemplate                        = False-      | isParallelBuild                             = True-      | otherwise                                   = False--    isParallelBuild = buildSettingNumJobs >= 2--    substLogFileName :: PathTemplate-                     -> Compiler -> Platform-                     -> PackageId -> UnitId -> FilePath-    substLogFileName template compiler platform pkgid uid =-        fromPathTemplate (substPathTemplate env template)-      where-        env = initialPathTemplateEnv-                pkgid uid (compilerInfo compiler) platform--    -- If the user has specified --remote-build-reporting=detailed or-    -- --build-log, use more verbose logging.-    ---    buildSettingLogVerbosity-      | overrideVerbosity = modifyVerbosity (max verbose) verbosity-      | otherwise         = verbosity--    overrideVerbosity-      | buildSettingBuildReports == DetailedReports = True-      | isJust givenTemplate                        = True-      | isParallelBuild                             = False-      | otherwise                                   = False--------------------------------------------------- Reading and writing project config files------- | Find the root of this project.------ Searches for an explicit @cabal.project@ file, in the current directory or--- parent directories. If no project file is found then the current dir is the--- project root (and the project will use an implicit config).----findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory-                -> Maybe FilePath -- ^ @cabal.project@ file name override-                -> IO (Either BadProjectRoot ProjectRoot)-findProjectRoot _ (Just projectFile)-  | isAbsolute projectFile = do-    exists <- doesFileExist projectFile-    if exists-      then do projectFile' <- canonicalizePath projectFile-              let projectRoot = ProjectRootExplicit (takeDirectory projectFile')-                                                    (takeFileName projectFile')-              return (Right projectRoot)-      else return (Left (BadProjectRootExplicitFile projectFile))--findProjectRoot mstartdir mprojectFile = do-    startdir <- maybe getCurrentDirectory canonicalizePath mstartdir-    homedir  <- getHomeDirectory-    probe startdir homedir-  where-    projectFileName = fromMaybe "cabal.project" mprojectFile--    -- Search upwards. If we get to the users home dir or the filesystem root,-    -- then use the current dir-    probe startdir homedir = go startdir-      where-        go dir | isDrive dir || dir == homedir =-          case mprojectFile of-            Nothing   -> return (Right (ProjectRootImplicit startdir))-            Just file -> return (Left (BadProjectRootExplicitFile file))-        go dir = do-          exists <- doesFileExist (dir </> projectFileName)-          if exists-            then return (Right (ProjectRootExplicit dir projectFileName))-            else go (takeDirectory dir)---- | Errors returned by 'findProjectRoot'.----data BadProjectRoot = BadProjectRootExplicitFile FilePath-#if MIN_VERSION_base(4,8,0)-  deriving (Show, Typeable)-#else-  deriving (Typeable)--instance Show BadProjectRoot where-  show = renderBadProjectRoot-#endif--instance Exception BadProjectRoot where-#if MIN_VERSION_base(4,8,0)-  displayException = renderBadProjectRoot-#endif--renderBadProjectRoot :: BadProjectRoot -> String-renderBadProjectRoot (BadProjectRootExplicitFile projectFile) =-    "The given project file '" ++ projectFile ++ "' does not exist."--withProjectOrGlobalConfig-    :: Verbosity                  -- ^ verbosity-    -> Flag Bool                  -- ^ whether to ignore local project-    -> Flag FilePath              -- ^ @--cabal-config@-    -> IO a                       -- ^ with project-    -> (ProjectConfig -> IO a)    -- ^ without projet-    -> IO a-withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do-    globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf-    without globalConfig-withProjectOrGlobalConfig verbosity _ignorePrj  gcf  with without =-    withProjectOrGlobalConfig' verbosity gcf with without--withProjectOrGlobalConfig'-    :: Verbosity-    -> Flag FilePath-    -> IO a-    -> (ProjectConfig -> IO a)-    -> IO a-withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do-  globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag--  let-    res' = catch with-      $ \case-        (BadPackageLocations prov locs)-          | prov == Set.singleton Implicit-          , let-            isGlobErr (BadLocGlobEmptyMatch _) = True-            isGlobErr _ = False-          , any isGlobErr locs ->-            without globalConfig-        err -> throwIO err--  catch res'-    $ \case-      (BadProjectRootExplicitFile "") -> without globalConfig-      err -> throwIO err---- | Read all the config relevant for a project. This includes the project--- file if any, plus other global config.----readProjectConfig :: Verbosity-                  -> Flag FilePath-                  -> DistDirLayout-                  -> Rebuild ProjectConfig-readProjectConfig verbosity configFileFlag distDirLayout = do-    global <- readGlobalConfig                verbosity configFileFlag-    local  <- readProjectLocalConfigOrDefault verbosity distDirLayout-    freeze <- readProjectLocalFreezeConfig    verbosity distDirLayout-    extra  <- readProjectLocalExtraConfig     verbosity distDirLayout-    return (global <> local <> freeze <> extra)----- | Reads an explicit @cabal.project@ file in the given project root dir,--- or returns the default project config for an implicitly defined project.----readProjectLocalConfigOrDefault :: Verbosity-                                -> DistDirLayout-                                -> Rebuild ProjectConfig-readProjectLocalConfigOrDefault verbosity distDirLayout = do-  usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile-  if usesExplicitProjectRoot-    then do-      readProjectFile verbosity distDirLayout "" "project file"-    else do-      monitorFiles [monitorNonExistentFile projectFile]-      return defaultImplicitProjectConfig--  where-    projectFile = distProjectFile distDirLayout ""--    defaultImplicitProjectConfig :: ProjectConfig-    defaultImplicitProjectConfig =-      mempty {-        -- We expect a package in the current directory.-        projectPackages         = [ "./*.cabal" ],--        projectConfigProvenance = Set.singleton Implicit-      }---- | Reads a @cabal.project.local@ file in the given project root dir,--- or returns empty. This file gets written by @cabal configure@, or in--- principle can be edited manually or by other tools.----readProjectLocalExtraConfig :: Verbosity -> DistDirLayout-                            -> Rebuild ProjectConfig-readProjectLocalExtraConfig verbosity distDirLayout =-    readProjectFile verbosity distDirLayout "local"-                             "project local configuration file"---- | Reads a @cabal.project.freeze@ file in the given project root dir,--- or returns empty. This file gets written by @cabal freeze@, or in--- principle can be edited manually or by other tools.----readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout-                             -> Rebuild ProjectConfig-readProjectLocalFreezeConfig verbosity distDirLayout =-    readProjectFile verbosity distDirLayout "freeze"-                             "project freeze file"---- | Reads a named config file in the given project root dir, or returns empty.----readProjectFile :: Verbosity-                -> DistDirLayout-                -> String-                -> String-                -> Rebuild ProjectConfig-readProjectFile verbosity DistDirLayout{distProjectFile}-                         extensionName extensionDescription = do-    exists <- liftIO $ doesFileExist extensionFile-    if exists-      then do monitorFiles [monitorFileHashed extensionFile]-              addProjectFileProvenance <$> liftIO readExtensionFile-      else do monitorFiles [monitorNonExistentFile extensionFile]-              return mempty-  where-    extensionFile = distProjectFile extensionName--    readExtensionFile =-          reportParseResult verbosity extensionDescription extensionFile-        . parseProjectConfig-      =<< readFile extensionFile--    addProjectFileProvenance config =-      config {-        projectConfigProvenance =-          Set.insert (Explicit extensionFile) (projectConfigProvenance config)-      }----- | Parse the 'ProjectConfig' format.------ For the moment this is implemented in terms of parsers for legacy--- configuration types, plus a conversion.----parseProjectConfig :: String -> OldParser.ParseResult ProjectConfig-parseProjectConfig content =-    convertLegacyProjectConfig <$>-      parseLegacyProjectConfig content----- | Render the 'ProjectConfig' format.------ For the moment this is implemented in terms of a pretty printer for the--- legacy configuration types, plus a conversion.----showProjectConfig :: ProjectConfig -> String-showProjectConfig =-    showLegacyProjectConfig . convertToLegacyProjectConfig----- | Write a @cabal.project.local@ file in the given project root dir.----writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO ()-writeProjectLocalExtraConfig DistDirLayout{distProjectFile} =-    writeProjectConfigFile (distProjectFile "local")----- | Write a @cabal.project.freeze@ file in the given project root dir.----writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO ()-writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} =-    writeProjectConfigFile (distProjectFile "freeze")----- | Write in the @cabal.project@ format to the given file.----writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()-writeProjectConfigFile file =-    writeFile file . showProjectConfig----- | Read the user's @~/.cabal/config@ file.----readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig-readGlobalConfig verbosity configFileFlag = do-    config     <- liftIO (loadConfig verbosity configFileFlag)-    configFile <- liftIO (getConfigFilePath configFileFlag)-    monitorFiles [monitorFileHashed configFile]-    return (convertLegacyGlobalConfig config)--reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a-reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do-    unless (null warnings) $-      let msg = unlines (map (OldParser.showPWarning filename) warnings)-       in warn verbosity msg-    return x-reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =-    let (line, msg) = OldParser.locatedErrorMsg err-     in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename-           ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg--------------------------------------------------- Finding packages in the project------- | The location of a package as part of a project. Local file paths are--- either absolute (if the user specified it as such) or they are relative--- to the project root.----data ProjectPackageLocation =-     ProjectPackageLocalCabalFile FilePath-   | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file-   | ProjectPackageLocalTarball   FilePath-   | ProjectPackageRemoteTarball  URI-   | ProjectPackageRemoteRepo     SourceRepoList-   | ProjectPackageNamed          PackageVersionConstraint-  deriving Show----- | Exception thrown by 'findProjectPackages'.----data BadPackageLocations-   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]-#if MIN_VERSION_base(4,8,0)-  deriving (Show, Typeable)-#else-  deriving (Typeable)--instance Show BadPackageLocations where-  show = renderBadPackageLocations-#endif--instance Exception BadPackageLocations where-#if MIN_VERSION_base(4,8,0)-  displayException = renderBadPackageLocations-#endif---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc--data BadPackageLocation-   = BadPackageLocationFile    BadPackageLocationMatch-   | BadLocGlobEmptyMatch      String-   | BadLocGlobBadMatches      String [BadPackageLocationMatch]-   | BadLocUnexpectedUriScheme String-   | BadLocUnrecognisedUri     String-   | BadLocUnrecognised        String-  deriving Show--data BadPackageLocationMatch-   = BadLocUnexpectedFile      String-   | BadLocNonexistantFile     String-   | BadLocDirNoCabalFile      String-   | BadLocDirManyCabalFiles   String-  deriving Show--renderBadPackageLocations :: BadPackageLocations -> String-renderBadPackageLocations (BadPackageLocations provenance bpls)-      -- There is no provenance information,-      -- render standard bad package error information.-    | Set.null provenance = renderErrors renderBadPackageLocation--      -- The configuration is implicit, render bad package locations-      -- using possibly specialized error messages.-    | Set.singleton Implicit == provenance =-        renderErrors renderImplicitBadPackageLocation--      -- The configuration contains both implicit and explicit provenance.-      -- This should not occur, and a message is output to assist debugging.-    | Implicit `Set.member` provenance =-           "Warning: both implicit and explicit configuration is present."-        ++ renderExplicit--      -- The configuration was read from one or more explicit path(s),-      -- list the locations and render the bad package error information.-      -- The intent is to supersede this with the relevant location information-      -- per package error.-    | otherwise = renderExplicit-  where-    renderErrors f = unlines (map f bpls)--    renderExplicit =-           "When using configuration(s) from "-        ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance))-        ++ ", the following errors occurred:\n"-        ++ renderErrors renderBadPackageLocation--    getExplicit (Explicit path) = Just path-    getExplicit Implicit        = Nothing----TODO: [nice to have] keep track of the config file (and src loc) packages--- were listed, to use in error messages---- | Render bad package location error information for the implicit--- @cabal.project@ configuration.------ TODO: This is currently not fully realized, with only one of the implicit--- cases handled. More cases should be added with informative help text--- about the issues related specifically when having no project configuration--- is present.-renderImplicitBadPackageLocation :: BadPackageLocation -> String-renderImplicitBadPackageLocation bpl = case bpl of-    BadLocGlobEmptyMatch pkglocstr ->-        "No cabal.project file or cabal file matching the default glob '"-     ++ pkglocstr ++ "' was found.\n"-     ++ "Please create a package description file <pkgname>.cabal "-     ++ "or a cabal.project file referencing the packages you "-     ++ "want to build."-    _ -> renderBadPackageLocation bpl--renderBadPackageLocation :: BadPackageLocation -> String-renderBadPackageLocation bpl = case bpl of-    BadPackageLocationFile badmatch ->-        renderBadPackageLocationMatch badmatch-    BadLocGlobEmptyMatch pkglocstr ->-        "The package location glob '" ++ pkglocstr-     ++ "' does not match any files or directories."-    BadLocGlobBadMatches pkglocstr failures ->-        "The package location glob '" ++ pkglocstr ++ "' does not match any "-     ++ "recognised forms of package. "-     ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures-    BadLocUnexpectedUriScheme pkglocstr ->-        "The package location URI '" ++ pkglocstr ++ "' does not use a "-     ++ "supported URI scheme. The supported URI schemes are http, https and "-     ++ "file."-    BadLocUnrecognisedUri pkglocstr ->-        "The package location URI '" ++ pkglocstr ++ "' does not appear to "-     ++ "be a valid absolute URI."-    BadLocUnrecognised pkglocstr ->-        "The package location syntax '" ++ pkglocstr ++ "' is not recognised."--renderBadPackageLocationMatch :: BadPackageLocationMatch -> String-renderBadPackageLocationMatch bplm = case bplm of-    BadLocUnexpectedFile pkglocstr ->-        "The package location '" ++ pkglocstr ++ "' is not recognised. The "-     ++ "supported file targets are .cabal files, .tar.gz tarballs or package "-     ++ "directories (i.e. directories containing a .cabal file)."-    BadLocNonexistantFile pkglocstr ->-        "The package location '" ++ pkglocstr ++ "' does not exist."-    BadLocDirNoCabalFile pkglocstr ->-        "The package directory '" ++ pkglocstr ++ "' does not contain any "-     ++ ".cabal file."-    BadLocDirManyCabalFiles pkglocstr ->-        "The package directory '" ++ pkglocstr ++ "' contains multiple "-     ++ ".cabal files (which is not currently supported)."---- | Given the project config,------ Throws 'BadPackageLocations'.----findProjectPackages :: DistDirLayout -> ProjectConfig-                    -> Rebuild [ProjectPackageLocation]-findProjectPackages DistDirLayout{distProjectRootDirectory}-                    ProjectConfig{..} = do--    requiredPkgs <- findPackageLocations True    projectPackages-    optionalPkgs <- findPackageLocations False   projectPackagesOptional-    let repoPkgs  = map ProjectPackageRemoteRepo projectPackagesRepo-        namedPkgs = map ProjectPackageNamed      projectPackagesNamed--    return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])-  where-    findPackageLocations required pkglocstr = do-      (problems, pkglocs) <--        partitionEithers <$> traverse (findPackageLocation required) pkglocstr-      unless (null problems) $-        liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems-      return (concat pkglocs)---    findPackageLocation :: Bool -> String-                        -> Rebuild (Either BadPackageLocation-                                          [ProjectPackageLocation])-    findPackageLocation _required@True pkglocstr =-      -- strategy: try first as a file:// or http(s):// URL.-      -- then as a file glob (usually encompassing single file)-      -- finally as a single file, for files that fail to parse as globs-                    checkIsUriPackage pkglocstr-      `mplusMaybeT` checkIsFileGlobPackage pkglocstr-      `mplusMaybeT` checkIsSingleFilePackage pkglocstr-      >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return---    findPackageLocation _required@False pkglocstr = do-      -- just globs for optional case-      res <- checkIsFileGlobPackage pkglocstr-      case res of-        Nothing              -> return (Left (BadLocUnrecognised pkglocstr))-        Just (Left _)        -> return (Right []) -- it's optional-        Just (Right pkglocs) -> return (Right pkglocs)---    checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage-      :: String -> Rebuild (Maybe (Either BadPackageLocation-                                         [ProjectPackageLocation]))-    checkIsUriPackage pkglocstr =-      case parseAbsoluteURI pkglocstr of-        Just uri@URI {-            uriScheme    = scheme,-            uriAuthority = Just URIAuth { uriRegName = host },-            uriPath      = path,-            uriQuery     = query,-            uriFragment  = frag-          }-          | recognisedScheme && not (null host) ->-            return (Just (Right [ProjectPackageRemoteTarball uri]))--          | scheme == "file:" && null host && null query && null frag ->-            checkIsSingleFilePackage path--          | not recognisedScheme && not (null host) ->-            return (Just (Left (BadLocUnexpectedUriScheme pkglocstr)))--          | recognisedScheme && null host ->-            return (Just (Left (BadLocUnrecognisedUri pkglocstr)))-          where-            recognisedScheme = scheme == "http:" || scheme == "https:"-                            || scheme == "file:"--        _ -> return Nothing---    checkIsFileGlobPackage pkglocstr =-      case simpleParsec pkglocstr of-        Nothing   -> return Nothing-        Just glob -> liftM Just $ do-          matches <- matchFileGlob glob-          case matches of-            [] | isJust (isTrivialFilePathGlob glob)-               -> return (Left (BadPackageLocationFile-                                  (BadLocNonexistantFile pkglocstr)))--            [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))--            _  -> do-              (failures, pkglocs) <- partitionEithers <$>-                                     traverse checkFilePackageMatch matches-              return $! case (failures, pkglocs) of-                ([failure], []) | isJust (isTrivialFilePathGlob glob)-                        -> Left (BadPackageLocationFile failure)-                (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)-                _       -> Right pkglocs---    checkIsSingleFilePackage pkglocstr = do-      let filename = distProjectRootDirectory </> pkglocstr-      isFile <- liftIO $ doesFileExist filename-      isDir  <- liftIO $ doesDirectoryExist filename-      if isFile || isDir-        then checkFilePackageMatch pkglocstr-         >>= either (return . Just . Left  . BadPackageLocationFile)-                    (return . Just . Right . (\x->[x]))-        else return Nothing---    checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch-                                                       ProjectPackageLocation)-    checkFilePackageMatch pkglocstr = do-      -- The pkglocstr may be absolute or may be relative to the project root.-      -- Either way, </> does the right thing here. We return relative paths if-      -- they were relative in the first place.-      let abspath = distProjectRootDirectory </> pkglocstr-      isFile <- liftIO $ doesFileExist abspath-      isDir  <- liftIO $ doesDirectoryExist abspath-      parentDirExists <- case takeDirectory abspath of-                           []  -> return False-                           dir -> liftIO $ doesDirectoryExist dir-      case () of-        _ | isDir-         -> do matches <- matchFileGlob (globStarDotCabal pkglocstr)-               case matches of-                 [cabalFile]-                     -> return (Right (ProjectPackageLocalDirectory-                                         pkglocstr cabalFile))-                 []  -> return (Left (BadLocDirNoCabalFile pkglocstr))-                 _   -> return (Left (BadLocDirManyCabalFiles pkglocstr))--          | extensionIsTarGz pkglocstr-         -> return (Right (ProjectPackageLocalTarball pkglocstr))--          | takeExtension pkglocstr == ".cabal"-         -> return (Right (ProjectPackageLocalCabalFile pkglocstr))--          | isFile-         -> return (Left (BadLocUnexpectedFile pkglocstr))--          | parentDirExists-         -> return (Left (BadLocNonexistantFile pkglocstr))--          | otherwise-         -> return (Left (BadLocUnexpectedFile pkglocstr))---    extensionIsTarGz f = takeExtension f                 == ".gz"-                      && takeExtension (dropExtension f) == ".tar"----- | A glob to find all the cabal files in a directory.------ For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.--- The directory part can be either absolute or relative.----globStarDotCabal :: FilePath -> FilePathGlob-globStarDotCabal dir =-    FilePathGlob-      (if isAbsolute dir then FilePathRoot root else FilePathRelative)-      (foldr (\d -> GlobDir [Literal d])-             (GlobFile [WildCard, Literal ".cabal"]) dirComponents)-  where-    (root, dirComponents) = fmap splitDirectories (splitDrive dir)-----TODO: [code cleanup] use sufficiently recent transformers package-mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)-mplusMaybeT ma mb = do-  mx <- ma-  case mx of-    Nothing -> mb-    Just x  -> return (Just x)------------------------------------------------------- Fetching and reading packages in the project------- | Read the @.cabal@ files for a set of packages. For remote tarballs and--- VCS source repos this also fetches them if needed.------ Note here is where we convert from project-root relative paths to absolute--- paths.----fetchAndReadSourcePackages-  :: Verbosity-  -> DistDirLayout-  -> ProjectConfigShared-  -> ProjectConfigBuildOnly-  -> [ProjectPackageLocation]-  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]-fetchAndReadSourcePackages verbosity distDirLayout-                           projectConfigShared-                           projectConfigBuildOnly-                           pkgLocations = do--    pkgsLocalDirectory <--      sequenceA-        [ readSourcePackageLocalDirectory verbosity dir cabalFile-        | location <- pkgLocations-        , (dir, cabalFile) <- projectPackageLocal location ]--    pkgsLocalTarball <--      sequenceA-        [ readSourcePackageLocalTarball verbosity path-        | ProjectPackageLocalTarball path <- pkgLocations ]--    pkgsRemoteTarball <- do-      getTransport <- delayInitSharedResource $-                      configureTransport verbosity progPathExtra-                                         preferredHttpTransport-      sequenceA-        [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout-                                                 getTransport uri-        | ProjectPackageRemoteTarball uri <- pkgLocations ]--    pkgsRemoteRepo <--      syncAndReadSourcePackagesRemoteRepos-        verbosity distDirLayout-        projectConfigShared-        [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ]--    let pkgsNamed =-          [ NamedPackage pkgname [PackagePropertyVersion verrange]-          | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ]--    return $ concat-      [ pkgsLocalDirectory-      , pkgsLocalTarball-      , pkgsRemoteTarball-      , pkgsRemoteRepo-      , pkgsNamed-      ]-  where-    projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)]-    projectPackageLocal (ProjectPackageLocalCabalFile     file) = [(dir, file)]-                                                where dir = takeDirectory file-    projectPackageLocal _ = []--    progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared)-    preferredHttpTransport =-      flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly)---- | A helper for 'fetchAndReadSourcePackages' to handle the case of--- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'.--- We simply read the @.cabal@ file.----readSourcePackageLocalDirectory-  :: Verbosity-  -> FilePath  -- ^ The package directory-  -> FilePath  -- ^ The package @.cabal@ file-  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))-readSourcePackageLocalDirectory verbosity dir cabalFile = do-    monitorFiles [monitorFileHashed cabalFile]-    root <- askRoot-    let location = LocalUnpackedPackage (root </> dir)-    liftIO $ fmap (mkSpecificSourcePackage location)-           . readSourcePackageCabalFile verbosity cabalFile-         =<< BS.readFile (root </> cabalFile)----- | A helper for 'fetchAndReadSourcePackages' to handle the case of--- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find--- the @.cabal@ file and read that.----readSourcePackageLocalTarball-  :: Verbosity-  -> FilePath-  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))-readSourcePackageLocalTarball verbosity tarballFile = do-    monitorFiles [monitorFile tarballFile]-    root <- askRoot-    let location = LocalTarballPackage (root </> tarballFile)-    liftIO $ fmap (mkSpecificSourcePackage location)-           . uncurry (readSourcePackageCabalFile verbosity)-         =<< extractTarballPackageCabalFile (root </> tarballFile)---- | A helper for 'fetchAndReadSourcePackages' to handle the case of--- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir--- and after that handle it like the local tarball case.----fetchAndReadSourcePackageRemoteTarball-  :: Verbosity-  -> DistDirLayout-  -> Rebuild HttpTransport-  -> URI-  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))-fetchAndReadSourcePackageRemoteTarball verbosity-                                       DistDirLayout {-                                         distDownloadSrcDirectory-                                       }-                                       getTransport-                                       tarballUri =-    -- The tarball download is expensive so we use another layer of file-    -- monitor to avoid it whenever possible.-    rerunIfChanged verbosity monitor tarballUri $ do--      -- Download-      transport <- getTransport-      liftIO $ do-        transportCheckHttps verbosity transport tarballUri-        notice verbosity ("Downloading " ++ show tarballUri)-        createDirectoryIfMissingVerbose verbosity True-                                        distDownloadSrcDirectory-        _ <- downloadURI transport verbosity tarballUri tarballFile-        return ()--      -- Read-      monitorFiles [monitorFile tarballFile]-      let location = RemoteTarballPackage tarballUri tarballFile-      liftIO $ fmap (mkSpecificSourcePackage location)-             . uncurry (readSourcePackageCabalFile verbosity)-           =<< extractTarballPackageCabalFile tarballFile-  where-    tarballStem = distDownloadSrcDirectory-              </> localFileNameForRemoteTarball tarballUri-    tarballFile = tarballStem <.> "tar.gz"--    monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))-    monitor = newFileMonitor (tarballStem <.> "cache")----- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of--- 'ProjectPackageRemoteRepo'.----syncAndReadSourcePackagesRemoteRepos-  :: Verbosity-  -> DistDirLayout-  -> ProjectConfigShared-  -> [SourceRepoList]-  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]-syncAndReadSourcePackagesRemoteRepos verbosity-                                     DistDirLayout{distDownloadSrcDirectory}-                                     ProjectConfigShared {-                                       projectConfigProgPathExtra-                                     }-                                    repos = do--    repos' <- either reportSourceRepoProblems return $-              validateSourceRepos repos--    -- All 'SourceRepo's grouped by referring to the "same" remote repo-    -- instance. So same location but can differ in commit/tag/branch/subdir.-    let reposByLocation :: Map (RepoType, String)-                               [(SourceRepoList, RepoType)]-        reposByLocation = Map.fromListWith (++)-                            [ ((rtype, rloc), [(repo, vcsRepoType vcs)])-                            | (repo, rloc, rtype, vcs) <- repos' ]--    --TODO: pass progPathExtra on to 'configureVCS'-    let _progPathExtra = fromNubList projectConfigProgPathExtra-    getConfiguredVCS <- delayInitSharedResources $ \repoType ->-                          let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in-                          configureVCS verbosity {-progPathExtra-} vcs--    concat <$> sequenceA-      [ rerunIfChanged verbosity monitor repoGroup' $ do-          vcs' <- getConfiguredVCS repoType-          syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'-      | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation-      , let repoGroup' = map fst repoGroup-            pathStem = distDownloadSrcDirectory-                   </> localFileNameForRemoteRepo primaryRepo-            monitor :: FileMonitor-                         [SourceRepoList]-                         [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]-            monitor  = newFileMonitor (pathStem <.> "cache")-      ]-  where-    syncRepoGroupAndReadSourcePackages-      :: VCS ConfiguredProgram-      -> FilePath-      -> [SourceRepoList]-      -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]-    syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do-        liftIO $ createDirectoryIfMissingVerbose verbosity False-                                                 distDownloadSrcDirectory--        -- For syncing we don't care about different 'SourceRepo' values that-        -- are just different subdirs in the same repo.-        syncSourceRepos verbosity vcs-          [ (repo, repoPath)-          | (repo, _, repoPath) <- repoGroupWithPaths ]-        -- TODO phadej 2020-06-18 add post-sync script--        -- But for reading we go through each 'SourceRepo' including its subdir-        -- value and have to know which path each one ended up in.-        sequenceA-          [ readPackageFromSourceRepo repoWithSubdir repoPath-          | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths-          , repoWithSubdir <- NE.toList reposWithSubdir ]-      where-        -- So to do both things above, we pair them up here.-        repoGroupWithPaths-          :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]-        repoGroupWithPaths =-          zipWith (\(x, y) z -> (x,y,z))-                  (mapGroup-                      [ (repo { srpSubdir = Proxy }, repo)-                      | repo <- foldMap (NE.toList . srpFanOut) repoGroup-                      ])-                  repoPaths--        mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]-        mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))--        -- The repos in a group are given distinct names by simple enumeration-        -- foo, foo-2, foo-3 etc-        repoPaths :: [FilePath]-        repoPaths = pathStem-                  : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]--    readPackageFromSourceRepo-        :: SourceRepositoryPackage Maybe-        -> FilePath-        -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))-    readPackageFromSourceRepo repo repoPath = do-        let packageDir :: FilePath-            packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)--        entries <- liftIO $ getDirectoryContents packageDir-        --TODO: dcoutts 2018-06-23: wrap exceptions-        case filter (\e -> takeExtension e == ".cabal") entries of-          []       -> liftIO $ throwIO $ NoCabalFileFound packageDir-          (_:_:_)  -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir-          [cabalFileName] -> do-            let cabalFilePath = packageDir </> cabalFileName-            monitorFiles [monitorFileHashed cabalFilePath]-            gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath--            -- write sdist tarball, to repoPath-pgkid-            tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir-            let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz"-            liftIO $ LBS.writeFile tarballPath tarball--            let location = RemoteSourceRepoPackage repo tarballPath-            return $ mkSpecificSourcePackage location gpd--    reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a-    reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems--    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String-    renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"----- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an--- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package--- from a given location.----mkSpecificSourcePackage :: PackageLocation FilePath-                        -> GenericPackageDescription-                        -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)-mkSpecificSourcePackage location pkg =-    SpecificSourcePackage SourcePackage-      { srcpkgPackageId     = packageId pkg-      , srcpkgDescription   = pkg-      , srcpkgSource        = fmap Just location-      , srcpkgDescrOverride = Nothing-      }----- | Errors reported upon failing to parse a @.cabal@ file.----data CabalFileParseError = CabalFileParseError-    FilePath           -- ^ @.cabal@ file path-    BS.ByteString      -- ^ @.cabal@ file contents-    (NonEmpty PError)  -- ^ errors-    (Maybe Version)    -- ^ We might discover the spec version the package needs-    [PWarning]         -- ^ warnings-  deriving (Typeable)---- | Manual instance which skips file contentes-instance Show CabalFileParseError where-    showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10)-        $ showString "CabalFileParseError"-        . showChar ' ' . showsPrec 11 fp-        . showChar ' ' . showsPrec 11 ("" :: String)-        . showChar ' ' . showsPrec 11 es-        . showChar ' ' . showsPrec 11 mv-        . showChar ' ' . showsPrec 11 ws--instance Exception CabalFileParseError-#if MIN_VERSION_base(4,8,0)-  where-  displayException = renderCabalFileParseError-#endif--renderCabalFileParseError :: CabalFileParseError -> String-renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) =-    renderParseError filePath contents errors warnings---- | Wrapper for the @.cabal@ file parser. It reports warnings on higher--- verbosity levels and throws 'CabalFileParseError' on failure.----readSourcePackageCabalFile :: Verbosity-                           -> FilePath-                           -> BS.ByteString-                           -> IO GenericPackageDescription-readSourcePackageCabalFile verbosity pkgfilename content =-    case runParseResult (parseGenericPackageDescription content) of-      (warnings, Right pkg) -> do-        unless (null warnings) $-          info verbosity (formatWarnings warnings)-        return pkg--      (warnings, Left (mspecVersion, errors)) ->-        throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings-  where-    formatWarnings warnings =-        "The package description file " ++ pkgfilename-     ++ " has warnings: "-     ++ unlines (map (showPWarning pkgfilename) warnings)----- | When looking for a package's @.cabal@ file we can find none, or several,--- both of which are failures.----data CabalFileSearchFailure-   = NoCabalFileFound FilePath-   | MultipleCabalFilesFound FilePath-  deriving (Show, Typeable)--instance Exception CabalFileSearchFailure----- | Find the @.cabal@ file within a tarball file and return it by value.------ Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception.----extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString)-extractTarballPackageCabalFile tarballFile =-    withBinaryFile tarballFile ReadMode $ \hnd -> do-      content <- LBS.hGetContents hnd-      case extractTarballPackageCabalFilePure tarballFile content of-        Left (Left  e) -> throwIO e-        Left (Right e) -> throwIO e-        Right (fileName, fileContent) ->-          (,) fileName <$> evaluate (LBS.toStrict fileContent)----- | Scan through a tar file stream and collect the @.cabal@ file, or fail.----extractTarballPackageCabalFilePure :: FilePath-                                   -> LBS.ByteString-                                   -> Either (Either Tar.FormatError-                                                     CabalFileSearchFailure)-                                             (FilePath, LBS.ByteString)-extractTarballPackageCabalFilePure tarballFile =-      check-    . accumEntryMap-    . Tar.filterEntries isCabalFile-    . Tar.read-    . GZipUtils.maybeDecompress-  where-    accumEntryMap = Tar.foldlEntries-                      (\m e -> Map.insert (Tar.entryTarPath e) e m)-                      Map.empty--    check (Left (e, _m)) = Left (Left e)-    check (Right m) = case Map.elems m of-        []     -> Left (Right $ NoCabalFileFound tarballFile)-        [file] -> case Tar.entryContent file of-          Tar.NormalFile content _ -> Right (Tar.entryPath file, content)-          _                        -> Left (Right $ NoCabalFileFound tarballFile)-        _files -> Left (Right $ MultipleCabalFilesFound tarballFile)--    isCabalFile e = case splitPath (Tar.entryPath e) of-      [     _dir, file] -> takeExtension file == ".cabal"-      [".", _dir, file] -> takeExtension file == ".cabal"-      _                 -> False----- | The name to use for a local file for a remote tarball 'SourceRepo'.--- This is deterministic based on the remote tarball URI, and is intended--- to produce non-clashing file names for different tarballs.----localFileNameForRemoteTarball :: URI -> FilePath-localFileNameForRemoteTarball uri =-    mangleName uri- ++ "-" ++  showHex locationHash ""-  where-    mangleName = truncateString 10 . dropExtension . dropExtension-               . takeFileName . dropTrailingPathSeparator . uriPath--    locationHash :: Word-    locationHash = fromIntegral (Hashable.hash (uriToString id uri ""))----- | The name to use for a local file or dir for a remote 'SourceRepo'.--- This is deterministic based on the source repo identity details, and--- intended to produce non-clashing file names for different repos.----localFileNameForRemoteRepo :: SourceRepoList -> FilePath-localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} =-    mangleName srpLocation ++ "-" ++ showHex locationHash ""-  where-    mangleName = truncateString 10 . dropExtension-               . takeFileName . dropTrailingPathSeparator--    -- just the parts that make up the "identity" of the repo-    locationHash :: Word-    locationHash =-      fromIntegral (Hashable.hash (show srpType, srpLocation))----- | Truncate a string, with a visual indication that it is truncated.-truncateString :: Int -> String -> String-truncateString n s | length s <= n = s-                   | otherwise     = take (n-1) s ++ "_"----- TODO: add something like this, here or in the project planning--- Based on the package location, which packages will be built inplace in the--- build tree vs placed in the store. This has various implications on what we--- can do with the package, e.g. can we run tests, ghci etc.------ packageIsLocalToProject :: ProjectPackageLocation -> Bool--------------------------------------------------- Checking configuration sanity-----data BadPerPackageCompilerPaths-   = BadPerPackageCompilerPaths [(PackageName, String)]-#if MIN_VERSION_base(4,8,0)-  deriving (Show, Typeable)-#else-  deriving (Typeable)--instance Show BadPerPackageCompilerPaths where-  show = renderBadPerPackageCompilerPaths-#endif--instance Exception BadPerPackageCompilerPaths where-#if MIN_VERSION_base(4,8,0)-  displayException = renderBadPerPackageCompilerPaths-#endif---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc--renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String-renderBadPerPackageCompilerPaths-  (BadPerPackageCompilerPaths ((pkgname, progname) : _)) =-    "The path to the compiler program (or programs used by the compiler) "- ++ "cannot be specified on a per-package basis in the cabal.project file "- ++ "(i.e. setting the '" ++ progname ++ "-location' for package '"- ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so "- ++ "specify the path in a global 'program-locations' section."- --TODO: [nice to have] better format control so we can pretty-print the- -- offending part of the project file. Currently the line wrapping breaks any- -- formatting.-renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths"---- | The project configuration is not allowed to specify program locations for--- programs used by the compiler as these have to be the same for each set of--- packages.------ We cannot check this until we know which programs the compiler uses, which--- in principle is not until we've configured the compiler.------ Throws 'BadPerPackageCompilerPaths'----checkBadPerPackageCompilerPaths :: [ConfiguredProgram]-                                -> Map PackageName PackageConfig-                                -> IO ()-checkBadPerPackageCompilerPaths compilerPrograms packagesConfig =-    case [ (pkgname, progname)-         | let compProgNames = Set.fromList (map programId compilerPrograms)-         ,  (pkgname, pkgconf) <- Map.toList packagesConfig-         , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))-         , progname `Set.member` compProgNames ] of-      [] -> return ()-      ps -> throwIO (BadPerPackageCompilerPaths ps)
− Distribution/Client/ProjectConfig/Legacy.hs 
@@ -1,1479 +0,0 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-}---- | Project configuration, implementation in terms of legacy types.----module Distribution.Client.ProjectConfig.Legacy (--    -- * Project config in terms of legacy types-    LegacyProjectConfig,-    parseLegacyProjectConfig,-    showLegacyProjectConfig,--    -- * Conversion to and from legacy config types-    commandLineFlagsToProjectConfig,-    convertLegacyProjectConfig,-    convertLegacyGlobalConfig,-    convertToLegacyProjectConfig,--    -- * Internals, just for tests-    parsePackageLocationTokenQ,-    renderPackageLocationToken,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Types.Flag (parsecFlagAssignment)--import Distribution.Client.ProjectConfig.Types-import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)-import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo)-import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..))-import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)--import Distribution.Client.Config-         ( SavedConfig(..), remoteRepoFields, postProcessRepo )--import Distribution.Client.CmdInstall.ClientInstallFlags-         ( ClientInstallFlags(..), defaultClientInstallFlags-         , clientInstallOptions )--import Distribution.Solver.Types.ConstraintSource--import Distribution.FieldGrammar-import Distribution.Package-import Distribution.Types.SourceRepo (RepoType)-import Distribution.PackageDescription-         ( dispFlagAssignment )-import Distribution.Simple.Compiler-         ( OptimisationLevel(..), DebugInfoLevel(..) )-import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )-import Distribution.Simple.Setup-         ( Flag(Flag), toFlag, fromFlagOrDefault-         , ConfigFlags(..), configureOptions-         , HaddockFlags(..), haddockOptions, defaultHaddockFlags-         , TestFlags(..), testOptions', defaultTestFlags-         , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags-         , programDbPaths', splitArgs-         )-import Distribution.Client.NixStyleOptions (NixStyleFlags (..))-import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)-import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand-         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags-         , InstallFlags(..), installOptions, defaultInstallFlags )-import Distribution.Simple.Program-         ( programName, knownPrograms )-import Distribution.Simple.Program.Db-         ( ProgramDb, defaultProgramDb )-import Distribution.Simple.Utils-         ( lowercase )-import Distribution.Utils.NubList-         ( toNubList, fromNubList, overNubList )-import Distribution.Simple.LocalBuildInfo-         ( toPathTemplate, fromPathTemplate )--import qualified Distribution.Deprecated.ReadP as Parse-import Distribution.Deprecated.ReadP-         ( ReadP, (+++) )-import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint-         ( Doc, ($+$) )-import qualified Distribution.Deprecated.ParseUtils as ParseUtils-import Distribution.Deprecated.ParseUtils-         ( ParseResult(..), PError(..), syntaxError, PWarning(..)-         , commaNewLineListFieldParsec, newLineListField, parseTokenQ-         , parseHaskellString, showToken -         , simpleFieldParsec-         )-import Distribution.Client.ParseUtils-import Distribution.Simple.Command-         ( CommandUI(commandOptions), ShowOrParseArgs(..)-         , OptionField, option, reqArg' )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint )-import Distribution.Parsec (ParsecParser)--import qualified Data.Map as Map--import Network.URI (URI (..))----------------------------------------------------------------------- Representing the project config file in terms of legacy types------- | We already have parsers\/pretty-printers for almost all the fields in the--- project config file, but they're in terms of the types used for the command--- line flags for Setup.hs or cabal commands. We don't want to redefine them--- all, at least not yet so for the moment we use the parsers at the old types--- and use conversion functions.------ Ultimately if\/when this project-based approach becomes the default then we--- can redefine the parsers directly for the new types.----data LegacyProjectConfig = LegacyProjectConfig {-       legacyPackages          :: [String],-       legacyPackagesOptional  :: [String],-       legacyPackagesRepo      :: [SourceRepoList],-       legacyPackagesNamed     :: [PackageVersionConstraint],--       legacySharedConfig      :: LegacySharedConfig,-       legacyAllConfig         :: LegacyPackageConfig,-       legacyLocalConfig       :: LegacyPackageConfig,-       legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig-     } deriving Generic--instance Monoid LegacyProjectConfig where-  mempty  = gmempty-  mappend = (<>)--instance Semigroup LegacyProjectConfig where-  (<>) = gmappend--data LegacyPackageConfig = LegacyPackageConfig {-       legacyConfigureFlags    :: ConfigFlags,-       legacyInstallPkgFlags   :: InstallFlags,-       legacyHaddockFlags      :: HaddockFlags,-       legacyTestFlags         :: TestFlags,-       legacyBenchmarkFlags    :: BenchmarkFlags-     } deriving Generic--instance Monoid LegacyPackageConfig where-  mempty  = gmempty-  mappend = (<>)--instance Semigroup LegacyPackageConfig where-  (<>) = gmappend--data LegacySharedConfig = LegacySharedConfig {-       legacyGlobalFlags       :: GlobalFlags,-       legacyConfigureShFlags  :: ConfigFlags,-       legacyConfigureExFlags  :: ConfigExFlags,-       legacyInstallFlags      :: InstallFlags,-       legacyClientInstallFlags:: ClientInstallFlags,-       legacyProjectFlags      :: ProjectFlags-     } deriving Generic--instance Monoid LegacySharedConfig where-  mempty  = gmempty-  mappend = (<>)--instance Semigroup LegacySharedConfig where-  (<>) = gmappend------------------------------------------------------------------------ Converting from and to the legacy types------- | Convert configuration from the @cabal configure@ or @cabal build@ command--- line into a 'ProjectConfig' value that can combined with configuration from--- other sources.------ At the moment this uses the legacy command line flag types. See--- 'LegacyProjectConfig' for an explanation.----commandLineFlagsToProjectConfig :: GlobalFlags-                                -> NixStyleFlags a-                                -> ClientInstallFlags-                                -> ProjectConfig-commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags =-    mempty {-      projectConfigBuildOnly     = convertLegacyBuildOnlyFlags-                                     globalFlags configFlags-                                     installFlags clientInstallFlags-                                     haddockFlags testFlags benchmarkFlags,-      projectConfigShared        = convertLegacyAllPackageFlags-                                     globalFlags configFlags-                                     configExFlags installFlags projectFlags,-      projectConfigLocalPackages = localConfig,-      projectConfigAllPackages   = allConfig-    }-  where (localConfig, allConfig) = splitConfig-                                 (convertLegacyPerPackageFlags-                                    configFlags installFlags-                                    haddockFlags testFlags benchmarkFlags)-        -- split the package config (from command line arguments) into-        -- those applied to all packages and those to local only.-        ---        -- for now we will just copy over the ProgramPaths/Args/Extra into-        -- the AllPackages.  The LocalPackages do not inherit them from-        -- AllPackages, and as such need to retain them.-        ---        -- The general decision rule for what to put into allConfig-        -- into localConfig is the following:-        ---        -- - anything that is host/toolchain/env specific should be applied-        --   to all packages, as packagesets have to be host/toolchain/env-        --   consistent.-        -- - anything else should be in the local config and could potentially-        --   be lifted into all-packages vial the `package *` cabal.project-        --   section.-        ---        splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)-        splitConfig pc = (pc-                         , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc-                                  , packageConfigProgramArgs  = packageConfigProgramArgs  pc-                                  , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc-                                  , packageConfigDocumentation = packageConfigDocumentation pc })---- | Convert from the types currently used for the user-wide @~/.cabal/config@--- file into the 'ProjectConfig' type.------ Only a subset of the 'ProjectConfig' can be represented in the user-wide--- config. In particular it does not include packages that are in the project,--- and it also doesn't support package-specific configuration (only--- configuration that applies to all packages).----convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig-convertLegacyGlobalConfig-    SavedConfig {-      savedGlobalFlags       = globalFlags,-      savedInstallFlags      = installFlags,-      savedClientInstallFlags= clientInstallFlags,-      savedConfigureFlags    = configFlags,-      savedConfigureExFlags  = configExFlags,-      savedUserInstallDirs   = _,-      savedGlobalInstallDirs = _,-      savedUploadFlags       = _,-      savedReportFlags       = _,-      savedHaddockFlags      = haddockFlags,-      savedTestFlags         = testFlags,-      savedBenchmarkFlags    = benchmarkFlags,-      savedProjectFlags      = projectFlags-    } =-    mempty {-      projectConfigBuildOnly   = configBuildOnly,-      projectConfigShared      = configShared,-      projectConfigAllPackages = configAllPackages-    }-  where-    --TODO: [code cleanup] eliminate use of default*Flags here and specify the-    -- defaults in the various resolve functions in terms of the new types.-    configExFlags'      = defaultConfigExFlags      <> configExFlags-    installFlags'       = defaultInstallFlags       <> installFlags-    clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags-    haddockFlags'       = defaultHaddockFlags       <> haddockFlags-    testFlags'          = defaultTestFlags          <> testFlags-    benchmarkFlags'     = defaultBenchmarkFlags     <> benchmarkFlags-    projectFlags'       = defaultProjectFlags       <> projectFlags--    configAllPackages   = convertLegacyPerPackageFlags-                            configFlags installFlags'-                            haddockFlags' testFlags' benchmarkFlags'-    configShared        = convertLegacyAllPackageFlags-                            globalFlags configFlags-                            configExFlags' installFlags' projectFlags'-    configBuildOnly     = convertLegacyBuildOnlyFlags-                            globalFlags configFlags-                            installFlags' clientInstallFlags'-                            haddockFlags' testFlags' benchmarkFlags'----- | Convert the project config from the legacy types to the 'ProjectConfig'--- and associated types. See 'LegacyProjectConfig' for an explanation of the--- approach.----convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig-convertLegacyProjectConfig-  LegacyProjectConfig {-    legacyPackages,-    legacyPackagesOptional,-    legacyPackagesRepo,-    legacyPackagesNamed,-    legacySharedConfig = LegacySharedConfig globalFlags configShFlags-                                            configExFlags installSharedFlags-                                            clientInstallFlags projectFlags,-    legacyAllConfig,-    legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags-                                             haddockFlags testFlags benchmarkFlags,-    legacySpecificConfig-  } =--    ProjectConfig {-      projectPackages              = legacyPackages,-      projectPackagesOptional      = legacyPackagesOptional,-      projectPackagesRepo          = legacyPackagesRepo,-      projectPackagesNamed         = legacyPackagesNamed,--      projectConfigBuildOnly       = configBuildOnly,-      projectConfigShared          = configPackagesShared,-      projectConfigProvenance      = mempty,-      projectConfigAllPackages     = configAllPackages,-      projectConfigLocalPackages   = configLocalPackages,-      projectConfigSpecificPackage = fmap perPackage legacySpecificConfig-    }-  where-    configAllPackages   = convertLegacyPerPackageFlags g i h t b-                            where LegacyPackageConfig g i h t b = legacyAllConfig-    configLocalPackages = convertLegacyPerPackageFlags-                            configFlags installPerPkgFlags haddockFlags-                            testFlags benchmarkFlags-    configPackagesShared= convertLegacyAllPackageFlags-                            globalFlags (configFlags <> configShFlags)-                            configExFlags installSharedFlags projectFlags-    configBuildOnly     = convertLegacyBuildOnlyFlags-                            globalFlags configShFlags-                            installSharedFlags clientInstallFlags-                            haddockFlags testFlags benchmarkFlags--    perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags-                                    perPkgHaddockFlags perPkgTestFlags-                                    perPkgBenchmarkFlags) =-      convertLegacyPerPackageFlags-        perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags-                          perPkgTestFlags perPkgBenchmarkFlags----- | Helper used by other conversion functions that returns the--- 'ProjectConfigShared' subset of the 'ProjectConfig'.----convertLegacyAllPackageFlags-    :: GlobalFlags-    -> ConfigFlags-    -> ConfigExFlags-    -> InstallFlags-    -> ProjectFlags-    -> ProjectConfigShared-convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags =-    ProjectConfigShared{..}-  where-    GlobalFlags {-      globalConfigFile        = projectConfigConfigFile,-      globalRemoteRepos       = projectConfigRemoteRepos,-      globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,-      globalActiveRepos       = projectConfigActiveRepos,-      globalProgPathExtra     = projectConfigProgPathExtra,-      globalStoreDir          = projectConfigStoreDir-    } = globalFlags--    ConfigFlags {-      configDistPref            = projectConfigDistDir,-      configHcFlavor            = projectConfigHcFlavor,-      configHcPath              = projectConfigHcPath,-      configHcPkg               = projectConfigHcPkg-    --configProgramPathExtra    = projectConfigProgPathExtra DELETE ME-    --configInstallDirs         = projectConfigInstallDirs,-    --configUserInstall         = projectConfigUserInstall,-    --configPackageDBs          = projectConfigPackageDBs,-    } = configFlags--    ConfigExFlags {-      configCabalVersion        = projectConfigCabalVersion,-      configExConstraints       = projectConfigConstraints,-      configPreferences         = projectConfigPreferences,-      configSolver              = projectConfigSolver,-      configAllowOlder          = projectConfigAllowOlder,-      configAllowNewer          = projectConfigAllowNewer,-      configWriteGhcEnvironmentFilesPolicy-                                = projectConfigWriteGhcEnvironmentFilesPolicy-    } = configExFlags--    InstallFlags {-      installHaddockIndex       = projectConfigHaddockIndex,-    --installReinstall          = projectConfigReinstall,-    --installAvoidReinstalls    = projectConfigAvoidReinstalls,-    --installOverrideReinstall  = projectConfigOverrideReinstall,-      installIndexState         = projectConfigIndexState,-      installMaxBackjumps       = projectConfigMaxBackjumps,-    --installUpgradeDeps        = projectConfigUpgradeDeps,-      installReorderGoals       = projectConfigReorderGoals,-      installCountConflicts     = projectConfigCountConflicts,-      installFineGrainedConflicts = projectConfigFineGrainedConflicts,-      installMinimizeConflictSet = projectConfigMinimizeConflictSet,-      installPerComponent       = projectConfigPerComponent,-      installIndependentGoals   = projectConfigIndependentGoals,-    --installShadowPkgs         = projectConfigShadowPkgs,-      installStrongFlags        = projectConfigStrongFlags,-      installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,-      installOnlyConstrained    = projectConfigOnlyConstrained-    } = installFlags--    ProjectFlags-        { flagProjectFileName = projectConfigProjectFile-        , flagIgnoreProject   = projectConfigIgnoreProject-        } = projectFlags---- | Helper used by other conversion functions that returns the--- 'PackageConfig' subset of the 'ProjectConfig'.----convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags-                             -> TestFlags -> BenchmarkFlags -> PackageConfig-convertLegacyPerPackageFlags configFlags installFlags-                             haddockFlags testFlags benchmarkFlags =-    PackageConfig{..}-  where-    ConfigFlags {-      configProgramPaths,-      configProgramArgs,-      configProgramPathExtra    = packageConfigProgramPathExtra,-      configVanillaLib          = packageConfigVanillaLib,-      configProfLib             = packageConfigProfLib,-      configSharedLib           = packageConfigSharedLib,-      configStaticLib           = packageConfigStaticLib,-      configDynExe              = packageConfigDynExe,-      configFullyStaticExe      = packageConfigFullyStaticExe,-      configProfExe             = packageConfigProfExe,-      configProf                = packageConfigProf,-      configProfDetail          = packageConfigProfDetail,-      configProfLibDetail       = packageConfigProfLibDetail,-      configConfigureArgs       = packageConfigConfigureArgs,-      configOptimization        = packageConfigOptimization,-      configProgPrefix          = packageConfigProgPrefix,-      configProgSuffix          = packageConfigProgSuffix,-      configGHCiLib             = packageConfigGHCiLib,-      configSplitSections       = packageConfigSplitSections,-      configSplitObjs           = packageConfigSplitObjs,-      configStripExes           = packageConfigStripExes,-      configStripLibs           = packageConfigStripLibs,-      configExtraLibDirs        = packageConfigExtraLibDirs,-      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,-      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,-      configConfigurationsFlags = packageConfigFlagAssignment,-      configTests               = packageConfigTests,-      configBenchmarks          = packageConfigBenchmarks,-      configCoverage            = coverage,-      configLibCoverage         = libcoverage, --deprecated-      configDebugInfo           = packageConfigDebugInfo,-      configRelocatable         = packageConfigRelocatable-    } = configFlags-    packageConfigProgramPaths   = MapLast    (Map.fromList configProgramPaths)-    packageConfigProgramArgs    = MapMappend (Map.fromListWith (++) configProgramArgs)--    packageConfigCoverage       = coverage <> libcoverage-    --TODO: defer this merging to the resolve phase--    InstallFlags {-      installDocumentation      = packageConfigDocumentation,-      installRunTests           = packageConfigRunTests-    } = installFlags--    HaddockFlags {-      haddockHoogle             = packageConfigHaddockHoogle,-      haddockHtml               = packageConfigHaddockHtml,-      haddockHtmlLocation       = packageConfigHaddockHtmlLocation,-      haddockForeignLibs        = packageConfigHaddockForeignLibs,-      haddockForHackage         = packageConfigHaddockForHackage,-      haddockExecutables        = packageConfigHaddockExecutables,-      haddockTestSuites         = packageConfigHaddockTestSuites,-      haddockBenchmarks         = packageConfigHaddockBenchmarks,-      haddockInternal           = packageConfigHaddockInternal,-      haddockCss                = packageConfigHaddockCss,-      haddockLinkedSource       = packageConfigHaddockLinkedSource,-      haddockQuickJump          = packageConfigHaddockQuickJump,-      haddockHscolourCss        = packageConfigHaddockHscolourCss,-      haddockContents           = packageConfigHaddockContents-    } = haddockFlags--    TestFlags {-      testHumanLog              = packageConfigTestHumanLog,-      testMachineLog            = packageConfigTestMachineLog,-      testShowDetails           = packageConfigTestShowDetails,-      testKeepTix               = packageConfigTestKeepTix,-      testWrapper               = packageConfigTestWrapper,-      testFailWhenNoTestSuites  = packageConfigTestFailWhenNoTestSuites,-      testOptions               = packageConfigTestTestOptions-    } = testFlags--    BenchmarkFlags {-      benchmarkOptions          = packageConfigBenchmarkOptions-    } = benchmarkFlags----- | Helper used by other conversion functions that returns the--- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.----convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags-                            -> InstallFlags -> ClientInstallFlags-                            -> HaddockFlags -> TestFlags-                            -> BenchmarkFlags-                            -> ProjectConfigBuildOnly-convertLegacyBuildOnlyFlags globalFlags configFlags-                              installFlags clientInstallFlags-                              haddockFlags _ _ =-    ProjectConfigBuildOnly{..}-  where-    projectConfigClientInstallFlags = clientInstallFlags-    GlobalFlags {-      globalCacheDir          = projectConfigCacheDir,-      globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = _,-      globalHttpTransport     = projectConfigHttpTransport,-      globalIgnoreExpiry      = projectConfigIgnoreExpiry-    } = globalFlags--    ConfigFlags {-      configVerbosity           = projectConfigVerbosity-    } = configFlags--    InstallFlags {-      installDryRun             = projectConfigDryRun,-      installOnly               = _,-      installOnlyDeps           = projectConfigOnlyDeps,-      installRootCmd            = _,-      installSummaryFile        = projectConfigSummaryFile,-      installLogFile            = projectConfigLogFile,-      installBuildReports       = projectConfigBuildReports,-      installReportPlanningFailure = projectConfigReportPlanningFailure,-      installSymlinkBinDir      = projectConfigSymlinkBinDir,-      installOneShot            = projectConfigOneShot,-      installNumJobs            = projectConfigNumJobs,-      installKeepGoing          = projectConfigKeepGoing,-      installOfflineMode        = projectConfigOfflineMode-    } = installFlags--    HaddockFlags {-      haddockKeepTempFiles      = projectConfigKeepTempFiles --TODO: this ought to live elsewhere-    } = haddockFlags---convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig-convertToLegacyProjectConfig-    projectConfig@ProjectConfig {-      projectPackages,-      projectPackagesOptional,-      projectPackagesRepo,-      projectPackagesNamed,-      projectConfigAllPackages,-      projectConfigLocalPackages,-      projectConfigSpecificPackage-    } =-    LegacyProjectConfig {-      legacyPackages         = projectPackages,-      legacyPackagesOptional = projectPackagesOptional,-      legacyPackagesRepo     = projectPackagesRepo,-      legacyPackagesNamed    = projectPackagesNamed,-      legacySharedConfig     = convertToLegacySharedConfig projectConfig,-      legacyAllConfig        = convertToLegacyPerPackageConfig-                                 projectConfigAllPackages,-      legacyLocalConfig      = convertToLegacyAllPackageConfig projectConfig-                            <> convertToLegacyPerPackageConfig-                                 projectConfigLocalPackages,-      legacySpecificConfig   = fmap convertToLegacyPerPackageConfig-                                    projectConfigSpecificPackage-    }--convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig-convertToLegacySharedConfig-    ProjectConfig {-      projectConfigBuildOnly     = ProjectConfigBuildOnly {..},-      projectConfigShared        = ProjectConfigShared {..},-      projectConfigAllPackages   = PackageConfig {-        packageConfigDocumentation-      }-    } =--    LegacySharedConfig-      { legacyGlobalFlags        = globalFlags-      , legacyConfigureShFlags   = configFlags-      , legacyConfigureExFlags   = configExFlags-      , legacyInstallFlags       = installFlags-      , legacyClientInstallFlags = projectConfigClientInstallFlags-      , legacyProjectFlags       = projectFlags-      }-  where-    globalFlags = GlobalFlags {-      globalVersion           = mempty,-      globalNumericVersion    = mempty,-      globalConfigFile        = projectConfigConfigFile,-      globalConstraintsFile   = mempty,-      globalRemoteRepos       = projectConfigRemoteRepos,-      globalCacheDir          = projectConfigCacheDir,-      globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,-      globalActiveRepos       = projectConfigActiveRepos,-      globalLogsDir           = projectConfigLogsDir,-      globalWorldFile         = mempty,-      globalIgnoreExpiry      = projectConfigIgnoreExpiry,-      globalHttpTransport     = projectConfigHttpTransport,-      globalNix               = mempty,-      globalStoreDir          = projectConfigStoreDir,-      globalProgPathExtra     = projectConfigProgPathExtra-    }--    configFlags = mempty {-      configVerbosity     = projectConfigVerbosity,-      configDistPref      = projectConfigDistDir-    }--    configExFlags = ConfigExFlags {-      configCabalVersion  = projectConfigCabalVersion,-      configExConstraints = projectConfigConstraints,-      configPreferences   = projectConfigPreferences,-      configSolver        = projectConfigSolver,-      configAllowOlder    = projectConfigAllowOlder,-      configAllowNewer    = projectConfigAllowNewer,-      configWriteGhcEnvironmentFilesPolicy-                          = projectConfigWriteGhcEnvironmentFilesPolicy-    }--    installFlags = InstallFlags {-      installDocumentation     = packageConfigDocumentation,-      installHaddockIndex      = projectConfigHaddockIndex,-      installDest              = Flag NoCopyDest,-      installDryRun            = projectConfigDryRun,-      installReinstall         = mempty, --projectConfigReinstall,-      installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,-      installOverrideReinstall = mempty, --projectConfigOverrideReinstall,-      installMaxBackjumps      = projectConfigMaxBackjumps,-      installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,-      installReorderGoals      = projectConfigReorderGoals,-      installCountConflicts    = projectConfigCountConflicts,-      installFineGrainedConflicts = projectConfigFineGrainedConflicts,-      installMinimizeConflictSet = projectConfigMinimizeConflictSet,-      installIndependentGoals  = projectConfigIndependentGoals,-      installShadowPkgs        = mempty, --projectConfigShadowPkgs,-      installStrongFlags       = projectConfigStrongFlags,-      installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,-      installOnlyConstrained   = projectConfigOnlyConstrained,-      installOnly              = mempty,-      installOnlyDeps          = projectConfigOnlyDeps,-      installIndexState        = projectConfigIndexState,-      installRootCmd           = mempty, --no longer supported-      installSummaryFile       = projectConfigSummaryFile,-      installLogFile           = projectConfigLogFile,-      installBuildReports      = projectConfigBuildReports,-      installReportPlanningFailure = projectConfigReportPlanningFailure,-      installSymlinkBinDir     = projectConfigSymlinkBinDir,-      installPerComponent      = projectConfigPerComponent,-      installOneShot           = projectConfigOneShot,-      installNumJobs           = projectConfigNumJobs,-      installKeepGoing         = projectConfigKeepGoing,-      installRunTests          = mempty,-      installOfflineMode       = projectConfigOfflineMode-    }--    projectFlags = ProjectFlags-        { flagProjectFileName = projectConfigProjectFile-        , flagIgnoreProject   = projectConfigIgnoreProject-        }---convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig-convertToLegacyAllPackageConfig-    ProjectConfig {-      projectConfigBuildOnly = ProjectConfigBuildOnly {..},-      projectConfigShared    = ProjectConfigShared {..}-    } =--    LegacyPackageConfig {-      legacyConfigureFlags = configFlags,-      legacyInstallPkgFlags= mempty,-      legacyHaddockFlags   = haddockFlags,-      legacyTestFlags      = mempty,-      legacyBenchmarkFlags = mempty-    }-  where-    configFlags = ConfigFlags {-      configArgs                = mempty,-      configPrograms_           = mempty,-      configProgramPaths        = mempty,-      configProgramArgs         = mempty,-      configProgramPathExtra    = mempty,-      configHcFlavor            = projectConfigHcFlavor,-      configHcPath              = projectConfigHcPath,-      configHcPkg               = projectConfigHcPkg,-      configInstantiateWith     = mempty,-      configVanillaLib          = mempty,-      configProfLib             = mempty,-      configSharedLib           = mempty,-      configStaticLib           = mempty,-      configDynExe              = mempty,-      configFullyStaticExe      = mempty,-      configProfExe             = mempty,-      configProf                = mempty,-      configProfDetail          = mempty,-      configProfLibDetail       = mempty,-      configConfigureArgs       = mempty,-      configOptimization        = mempty,-      configProgPrefix          = mempty,-      configProgSuffix          = mempty,-      configInstallDirs         = mempty,-      configScratchDir          = mempty,-      configDistPref            = mempty,-      configCabalFilePath       = mempty,-      configVerbosity           = mempty,-      configUserInstall         = mempty, --projectConfigUserInstall,-      configPackageDBs          = mempty, --projectConfigPackageDBs,-      configGHCiLib             = mempty,-      configSplitSections       = mempty,-      configSplitObjs           = mempty,-      configStripExes           = mempty,-      configStripLibs           = mempty,-      configExtraLibDirs        = mempty,-      configExtraFrameworkDirs  = mempty,-      configConstraints         = mempty,-      configDependencies        = mempty,-      configExtraIncludeDirs    = mempty,-      configDeterministic       = mempty,-      configIPID                = mempty,-      configCID                 = mempty,-      configConfigurationsFlags = mempty,-      configTests               = mempty,-      configCoverage            = mempty, --TODO: don't merge-      configLibCoverage         = mempty, --TODO: don't merge-      configExactConfiguration  = mempty,-      configBenchmarks          = mempty,-      configFlagError           = mempty,                --TODO: ???-      configRelocatable         = mempty,-      configDebugInfo           = mempty,-      configUseResponseFiles    = mempty,-      configAllowDependingOnPrivateLibs = mempty-    }--    haddockFlags = mempty {-      haddockKeepTempFiles = projectConfigKeepTempFiles-    }---convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig-convertToLegacyPerPackageConfig PackageConfig {..} =-    LegacyPackageConfig {-      legacyConfigureFlags  = configFlags,-      legacyInstallPkgFlags = installFlags,-      legacyHaddockFlags    = haddockFlags,-      legacyTestFlags       = testFlags,-      legacyBenchmarkFlags  = benchmarkFlags-    }-  where-    configFlags = ConfigFlags {-      configArgs                = mempty,-      configPrograms_           = configPrograms_ mempty,-      configProgramPaths        = Map.toList (getMapLast packageConfigProgramPaths),-      configProgramArgs         = Map.toList (getMapMappend packageConfigProgramArgs),-      configProgramPathExtra    = packageConfigProgramPathExtra,-      configHcFlavor            = mempty,-      configHcPath              = mempty,-      configHcPkg               = mempty,-      configInstantiateWith     = mempty,-      configVanillaLib          = packageConfigVanillaLib,-      configProfLib             = packageConfigProfLib,-      configSharedLib           = packageConfigSharedLib,-      configStaticLib           = packageConfigStaticLib,-      configDynExe              = packageConfigDynExe,-      configFullyStaticExe      = packageConfigFullyStaticExe,-      configProfExe             = packageConfigProfExe,-      configProf                = packageConfigProf,-      configProfDetail          = packageConfigProfDetail,-      configProfLibDetail       = packageConfigProfLibDetail,-      configConfigureArgs       = packageConfigConfigureArgs,-      configOptimization        = packageConfigOptimization,-      configProgPrefix          = packageConfigProgPrefix,-      configProgSuffix          = packageConfigProgSuffix,-      configInstallDirs         = mempty,-      configScratchDir          = mempty,-      configDistPref            = mempty,-      configCabalFilePath       = mempty,-      configVerbosity           = mempty,-      configUserInstall         = mempty,-      configPackageDBs          = mempty,-      configGHCiLib             = packageConfigGHCiLib,-      configSplitSections       = packageConfigSplitSections,-      configSplitObjs           = packageConfigSplitObjs,-      configStripExes           = packageConfigStripExes,-      configStripLibs           = packageConfigStripLibs,-      configExtraLibDirs        = packageConfigExtraLibDirs,-      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,-      configConstraints         = mempty,-      configDependencies        = mempty,-      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,-      configIPID                = mempty,-      configCID                 = mempty,-      configDeterministic       = mempty,-      configConfigurationsFlags = packageConfigFlagAssignment,-      configTests               = packageConfigTests,-      configCoverage            = packageConfigCoverage, --TODO: don't merge-      configLibCoverage         = packageConfigCoverage, --TODO: don't merge-      configExactConfiguration  = mempty,-      configBenchmarks          = packageConfigBenchmarks,-      configFlagError           = mempty,                --TODO: ???-      configRelocatable         = packageConfigRelocatable,-      configDebugInfo           = packageConfigDebugInfo,-      configUseResponseFiles    = mempty,-      configAllowDependingOnPrivateLibs = mempty-    }--    installFlags = mempty {-      installDocumentation      = packageConfigDocumentation,-      installRunTests           = packageConfigRunTests-    }--    haddockFlags = HaddockFlags {-      haddockProgramPaths  = mempty,-      haddockProgramArgs   = mempty,-      haddockHoogle        = packageConfigHaddockHoogle,-      haddockHtml          = packageConfigHaddockHtml,-      haddockHtmlLocation  = packageConfigHaddockHtmlLocation,-      haddockForHackage    = packageConfigHaddockForHackage,-      haddockForeignLibs   = packageConfigHaddockForeignLibs,-      haddockExecutables   = packageConfigHaddockExecutables,-      haddockTestSuites    = packageConfigHaddockTestSuites,-      haddockBenchmarks    = packageConfigHaddockBenchmarks,-      haddockInternal      = packageConfigHaddockInternal,-      haddockCss           = packageConfigHaddockCss,-      haddockLinkedSource  = packageConfigHaddockLinkedSource,-      haddockQuickJump     = packageConfigHaddockQuickJump,-      haddockHscolourCss   = packageConfigHaddockHscolourCss,-      haddockContents      = packageConfigHaddockContents,-      haddockDistPref      = mempty,-      haddockKeepTempFiles = mempty,-      haddockVerbosity     = mempty,-      haddockCabalFilePath = mempty,-      haddockArgs          = mempty-    }--    testFlags = TestFlags {-      testDistPref    = mempty,-      testVerbosity   = mempty,-      testHumanLog    = packageConfigTestHumanLog,-      testMachineLog  = packageConfigTestMachineLog,-      testShowDetails = packageConfigTestShowDetails,-      testKeepTix     = packageConfigTestKeepTix,-      testWrapper     = packageConfigTestWrapper,-      testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,-      testOptions     = packageConfigTestTestOptions-    }--    benchmarkFlags = BenchmarkFlags {-      benchmarkDistPref  = mempty,-      benchmarkVerbosity = mempty,-      benchmarkOptions   = packageConfigBenchmarkOptions-    }----------------------------------------------------- Parsing and showing the project config file-----parseLegacyProjectConfig :: String -> ParseResult LegacyProjectConfig-parseLegacyProjectConfig =-    parseConfig legacyProjectConfigFieldDescrs-                legacyPackageConfigSectionDescrs-                legacyPackageConfigFGSectionDescrs-                mempty--showLegacyProjectConfig :: LegacyProjectConfig -> String-showLegacyProjectConfig config =-    Disp.render $-    showConfig  legacyProjectConfigFieldDescrs-                legacyPackageConfigSectionDescrs-                legacyPackageConfigFGSectionDescrs-                config-  $+$-    Disp.text ""---legacyProjectConfigFieldDescrs :: [FieldDescr LegacyProjectConfig]-legacyProjectConfigFieldDescrs =--    [ newLineListField "packages"-        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ-        legacyPackages-        (\v flags -> flags { legacyPackages = v })-    , newLineListField "optional-packages"-        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ-        legacyPackagesOptional-        (\v flags -> flags { legacyPackagesOptional = v })-    , commaNewLineListFieldParsec "extra-packages"-        pretty parsec-        legacyPackagesNamed-        (\v flags -> flags { legacyPackagesNamed = v })-    ]-- ++ map (liftField-           legacySharedConfig-           (\flags conf -> conf { legacySharedConfig = flags }))-        legacySharedConfigFieldDescrs-- ++ map (liftField-           legacyLocalConfig-           (\flags conf -> conf { legacyLocalConfig = flags }))-        legacyPackageConfigFieldDescrs---- | This is a bit tricky since it has to cover globs which have embedded @,@--- chars. But we don't just want to parse strictly as a glob since we want to--- allow http urls which don't parse as globs, and possibly some--- system-dependent file paths. So we parse fairly liberally as a token, but--- we allow @,@ inside matched @{}@ braces.----parsePackageLocationTokenQ :: ReadP r String-parsePackageLocationTokenQ = parseHaskellString-                   Parse.<++ parsePackageLocationToken-  where-    parsePackageLocationToken :: ReadP r String-    parsePackageLocationToken = fmap fst (Parse.gather outerTerm)-      where-        outerTerm   = alternateEither1 outerToken (braces innerTerm)-        innerTerm   = alternateEither  innerToken (braces innerTerm)-        outerToken  = Parse.munch1 outerChar >> return ()-        innerToken  = Parse.munch1 innerChar >> return ()-        outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')-        innerChar c = not (isSpace c || c == '{' || c == '}')-        braces      = Parse.between (Parse.char '{') (Parse.char '}')--    alternateEither, alternateEither1,-      alternatePQs, alternate1PQs, alternateQsP, alternate1QsP-      :: ReadP r () -> ReadP r () -> ReadP r ()--    alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p-    alternateEither  p q = alternateEither1 p q +++ return ()-    alternate1PQs    p q = p >> alternateQsP q p-    alternatePQs     p q = alternate1PQs p q +++ return ()-    alternate1QsP    q p = Parse.many1 q >> alternatePQs p q-    alternateQsP     q p = alternate1QsP q p +++ return ()--renderPackageLocationToken :: String -> String-renderPackageLocationToken s | needsQuoting = show s-                             | otherwise    = s-  where-    needsQuoting  = not (ok 0 s)-                 || s == "." -- . on its own on a line has special meaning-                 || take 2 s == "--" -- on its own line is comment syntax-                 --TODO: [code cleanup] these "." and "--" escaping issues-                 -- ought to be dealt with systematically in ParseUtils.-    ok :: Int -> String -> Bool-    ok n []       = n == 0-    ok _ ('"':_)  = False-    ok n ('{':cs) = ok (n+1) cs-    ok n ('}':cs) = ok (n-1) cs-    ok n (',':cs) = (n > 0) && ok n cs-    ok _ (c:_)-      | isSpace c = False-    ok n (_  :cs) = ok n cs---legacySharedConfigFieldDescrs :: [FieldDescr LegacySharedConfig]-legacySharedConfigFieldDescrs = concat-  [ liftFields-      legacyGlobalFlags-      (\flags conf -> conf { legacyGlobalFlags = flags })-  . addFields-      [ newLineListField "extra-prog-path-shared-only"-          showTokenQ parseTokenQ-          (fromNubList . globalProgPathExtra)-          (\v conf -> conf { globalProgPathExtra = toNubList v })-      ]-  . filterFields-      [ "remote-repo-cache"-      , "logs-dir", "store-dir", "ignore-expiry", "http-transport"-      , "active-repositories"-      ]-  . commandOptionsToFields-  $ commandOptions (globalCommand []) ParseArgs--  , liftFields-      legacyConfigureShFlags-      (\flags conf -> conf { legacyConfigureShFlags = flags })-  . filterFields ["verbose", "builddir" ]-  . commandOptionsToFields-  $ configureOptions ParseArgs--  , liftFields-      legacyConfigureExFlags-      (\flags conf -> conf { legacyConfigureExFlags = flags })-  . addFields-      [ commaNewLineListFieldParsec "constraints"-        (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)-        configExConstraints (\v conf -> conf { configExConstraints = v })--      , commaNewLineListFieldParsec "preferences"-        pretty parsec-        configPreferences (\v conf -> conf { configPreferences = v })--      , monoidFieldParsec "allow-older"-        (maybe mempty pretty) (fmap Just parsec)-        (fmap unAllowOlder . configAllowOlder)-        (\v conf -> conf { configAllowOlder = fmap AllowOlder v })--      , monoidFieldParsec "allow-newer"-        (maybe mempty pretty) (fmap Just parsec)-        (fmap unAllowNewer . configAllowNewer)-        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })-      ]-  . filterFields-      [ "cabal-lib-version", "solver", "write-ghc-environment-files"-        -- not "constraint" or "preference", we use our own plural ones above-      ]-  . commandOptionsToFields-  $ configureExOptions ParseArgs constraintSrc--  , liftFields-      legacyInstallFlags-      (\flags conf -> conf { legacyInstallFlags = flags })-  . addFields-      [ newLineListField "build-summary"-          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)-          (fromNubList . installSummaryFile)-          (\v conf -> conf { installSummaryFile = toNubList v })-      ]-  . filterFields-      [ "doc-index-file"-      , "root-cmd", "symlink-bindir"-      , "build-log"-      , "remote-build-reporting", "report-planning-failure"-      , "one-shot", "jobs", "keep-going", "offline", "per-component"-        -- solver flags:-      , "max-backjumps", "reorder-goals", "count-conflicts"-      , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals"-      , "strong-flags" , "allow-boot-library-installs"-      , "reject-unconstrained-dependencies", "index-state"-      ]-  . commandOptionsToFields-  $ installOptions ParseArgs--  , liftFields-      legacyClientInstallFlags-      (\flags conf -> conf { legacyClientInstallFlags = flags })-  . commandOptionsToFields-  $ clientInstallOptions ParseArgs--  , liftFields-      legacyProjectFlags-      (\flags conf -> conf { legacyProjectFlags = flags })-  . commandOptionsToFields-  $ projectFlagsOptions ParseArgs--  ]-  where-    constraintSrc = ConstraintSourceProjectConfig "TODO" -- TODO: is a filepath---legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]-legacyPackageConfigFieldDescrs =-  ( liftFields-      legacyConfigureFlags-      (\flags conf -> conf { legacyConfigureFlags = flags })-  . addFields-      [ newLineListField "extra-include-dirs"-          showTokenQ parseTokenQ-          configExtraIncludeDirs-          (\v conf -> conf { configExtraIncludeDirs = v })-      , newLineListField "extra-lib-dirs"-          showTokenQ parseTokenQ-          configExtraLibDirs-          (\v conf -> conf { configExtraLibDirs = v })-      , newLineListField "extra-framework-dirs"-          showTokenQ parseTokenQ-          configExtraFrameworkDirs-          (\v conf -> conf { configExtraFrameworkDirs = v })-      , newLineListField "extra-prog-path"-          showTokenQ parseTokenQ-          (fromNubList . configProgramPathExtra)-          (\v conf -> conf { configProgramPathExtra = toNubList v })-      , newLineListField "configure-options"-          showTokenQ parseTokenQ-          configConfigureArgs-          (\v conf -> conf { configConfigureArgs = v })-      , simpleFieldParsec "flags"-          dispFlagAssignment parsecFlagAssignment-          configConfigurationsFlags-          (\v conf -> conf { configConfigurationsFlags = v })-      ]-  . filterFields-      [ "with-compiler", "with-hc-pkg"-      , "program-prefix", "program-suffix"-      , "library-vanilla", "library-profiling"-      , "shared", "static", "executable-dynamic", "executable-static"-      , "profiling", "executable-profiling"-      , "profiling-detail", "library-profiling-detail"-      , "library-for-ghci", "split-objs", "split-sections"-      , "executable-stripping", "library-stripping"-      , "tests", "benchmarks"-      , "coverage", "library-coverage"-      , "relocatable"-        -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"-        -- or "extra-prog-path". We use corrected ones above that parse-        -- as list fields.-      ]-  . commandOptionsToFields-  ) (configureOptions ParseArgs)- ++-    liftFields-      legacyConfigureFlags-      (\flags conf -> conf { legacyConfigureFlags = flags })-    [ overrideFieldCompiler-    , overrideFieldOptimization-    , overrideFieldDebugInfo-    ]- ++-  ( liftFields-      legacyInstallPkgFlags-      (\flags conf -> conf { legacyInstallPkgFlags = flags })-  . filterFields-      [ "documentation", "run-tests"-      ]-  . commandOptionsToFields-  ) (installOptions ParseArgs)- ++-  ( liftFields-      legacyHaddockFlags-      (\flags conf -> conf { legacyHaddockFlags = flags })-  . mapFieldNames-      ("haddock-"++)-  . addFields-      [ simpleFieldParsec "for-hackage"-          -- TODO: turn this into a library function-          (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty)-          haddockForHackage (\v conf -> conf { haddockForHackage = v })-      ]-  . filterFields-      [ "hoogle", "html", "html-location"-      , "foreign-libraries"-      , "executables", "tests", "benchmarks", "all", "internal", "css"-      , "hyperlink-source", "quickjump", "hscolour-css"-      , "contents-location", "keep-temp-files"-      ]-  . commandOptionsToFields-  ) (haddockOptions ParseArgs)- ++-  ( liftFields-      legacyTestFlags-      (\flags conf -> conf { legacyTestFlags = flags })-  . mapFieldNames-      prefixTest-  . addFields-      [ newLineListField "test-options"-          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)-          testOptions-          (\v conf -> conf { testOptions = v })-      ]-  . filterFields-      [ "log", "machine-log", "show-details", "keep-tix-files"-      , "fail-when-no-test-suites", "test-wrapper" ]-  . commandOptionsToFields-  ) (testOptions' ParseArgs)- ++-  ( liftFields-      legacyBenchmarkFlags-      (\flags conf -> conf { legacyBenchmarkFlags = flags })-  . addFields-      [ newLineListField "benchmark-options"-          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)-          benchmarkOptions-          (\v conf -> conf { benchmarkOptions = v })-      ]-  . filterFields-      []-  . commandOptionsToFields-  ) (benchmarkOptions' ParseArgs)---  where-    overrideFieldCompiler =-      simpleFieldParsec "compiler"-        (fromFlagOrDefault Disp.empty . fmap pretty)-        (toFlag <$> parsec <|> pure mempty)-        configHcFlavor (\v flags -> flags { configHcFlavor = v })---    -- TODO: [code cleanup] The following is a hack. The "optimization" and-    -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.-    -- Instead of a hand-written parser and printer, we should handle this case-    -- properly in the library.--    overrideFieldOptimization =-      liftField configOptimization-                (\v flags -> flags { configOptimization = v }) $-      let name = "optimization" in-      FieldDescr name-        (\f -> case f of-                 Flag NoOptimisation      -> Disp.text "False"-                 Flag NormalOptimisation  -> Disp.text "True"-                 Flag MaximumOptimisation -> Disp.text "2"-                 _                        -> Disp.empty)-        (\line str _ -> case () of-         _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)-           |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)-           |  str == "0"     -> ParseOk [] (Flag NoOptimisation)-           |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)-           |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)-           | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)-           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalOptimisation)-           | otherwise       -> ParseFailed (NoParse name line)-           where-             lstr = lowercase str-             caseWarning = PWarning $-               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")--    overrideFieldDebugInfo =-      liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $-      let name = "debug-info" in-      FieldDescr name-        (\f -> case f of-                 Flag NoDebugInfo      -> Disp.text "False"-                 Flag MinimalDebugInfo -> Disp.text "1"-                 Flag NormalDebugInfo  -> Disp.text "True"-                 Flag MaximalDebugInfo -> Disp.text "3"-                 _                     -> Disp.empty)-        (\line str _ -> case () of-         _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)-           |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)-           |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)-           |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)-           |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)-           |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)-           | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)-           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)-           | otherwise       -> ParseFailed (NoParse name line)-           where-             lstr = lowercase str-             caseWarning = PWarning $-               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")--    prefixTest name | "test-" `isPrefixOf` name = name-                    | otherwise = "test-" ++ name---legacyPackageConfigFGSectionDescrs-    :: ( FieldGrammar c g, Applicative (g SourceRepoList)-       , c (Identity RepoType), c (List NoCommaFSep FilePathNT String)-       )-    => [FGSectionDescr g LegacyProjectConfig]-legacyPackageConfigFGSectionDescrs =-    [ packageRepoSectionDescr-    ]--legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]-legacyPackageConfigSectionDescrs =-    [ packageSpecificOptionsSectionDescr-    , liftSection-        legacyLocalConfig-        (\flags conf -> conf { legacyLocalConfig = flags })-        programOptionsSectionDescr-    , liftSection-        legacyLocalConfig-        (\flags conf -> conf { legacyLocalConfig = flags })-        programLocationsSectionDescr-    , liftSection-        legacySharedConfig-        (\flags conf -> conf { legacySharedConfig = flags }) $-      liftSection-        legacyGlobalFlags-        (\flags conf -> conf { legacyGlobalFlags = flags })-        remoteRepoSectionDescr-    ]--packageRepoSectionDescr-    :: ( FieldGrammar c g, Applicative (g SourceRepoList)-       , c (Identity RepoType), c (List NoCommaFSep FilePathNT String)-       )-    => FGSectionDescr g LegacyProjectConfig-packageRepoSectionDescr = FGSectionDescr-  { fgSectionName        = "source-repository-package"-  , fgSectionGrammar     = sourceRepositoryPackageGrammar-  , fgSectionGet         = map (\x->("", x)) . legacyPackagesRepo-  , fgSectionSet         =-        \lineno unused pkgrepo projconf -> do-          unless (null unused) $-            syntaxError lineno "the section 'source-repository-package' takes no arguments"-          return projconf {-            legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]-          }-  }---- | The definitions of all the fields that can appear in the @package pkgfoo@--- and @package *@ sections of the @cabal.project@-format files.----packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig]-packageSpecificOptionsFieldDescrs =-    legacyPackageConfigFieldDescrs- ++ programOptionsFieldDescrs-      (configProgramArgs . legacyConfigureFlags)-      (\args pkgconf -> pkgconf {-          legacyConfigureFlags = (legacyConfigureFlags pkgconf) {-            configProgramArgs  = args-          }-        }-      )- ++ liftFields-      legacyConfigureFlags-      (\flags pkgconf -> pkgconf {-          legacyConfigureFlags = flags-        }-      )-      programLocationsFieldDescrs---- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format--- files. This section is per-package name. The special package @*@ applies to all--- packages used anywhere by the project, locally or as dependencies.----packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig-packageSpecificOptionsSectionDescr =-    SectionDescr {-      sectionName        = "package",-      sectionFields      = packageSpecificOptionsFieldDescrs,-      sectionSubsections = [],-      sectionGet         = \projconf ->-                             [ (prettyShow pkgname, pkgconf)-                             | (pkgname, pkgconf) <--                                 Map.toList . getMapMappend-                               . legacySpecificConfig $ projconf ]-                          ++ [ ("*", legacyAllConfig projconf) ],-      sectionSet         =-        \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of-          "*" -> return projconf {-                   legacyAllConfig = legacyAllConfig projconf <> pkgconf-                 }-          _   -> do-            pkgname <- case simpleParsec pkgnamestr of-              Just pkgname -> return pkgname-              Nothing      -> syntaxError lineno $-                                  "a 'package' section requires a package name "-                               ++ "as an argument"-            return projconf {-              legacySpecificConfig =-                MapMappend $-                Map.insertWith mappend pkgname pkgconf-                               (getMapMappend $ legacySpecificConfig projconf)-            },-      sectionEmpty       = mempty-    }--programOptionsFieldDescrs :: (a -> [(String, [String])])-                          -> ([(String, [String])] -> a -> a)-                          -> [FieldDescr a]-programOptionsFieldDescrs get' set =-    commandOptionsToFields-  $ programDbOptions-      defaultProgramDb-      ParseArgs get' set--programOptionsSectionDescr :: SectionDescr LegacyPackageConfig-programOptionsSectionDescr =-    SectionDescr {-      sectionName        = "program-options",-      sectionFields      = programOptionsFieldDescrs-                             configProgramArgs-                             (\args conf -> conf { configProgramArgs = args }),-      sectionSubsections = [],-      sectionGet         = (\x->[("", x)])-                         . legacyConfigureFlags,-      sectionSet         =-        \lineno unused confflags pkgconf -> do-          unless (null unused) $-            syntaxError lineno "the section 'program-options' takes no arguments"-          return pkgconf {-            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags-          },-      sectionEmpty       = mempty-    }--programLocationsFieldDescrs :: [FieldDescr ConfigFlags]-programLocationsFieldDescrs =-     commandOptionsToFields-   $ programDbPaths'-       (++ "-location")-       defaultProgramDb-       ParseArgs-       configProgramPaths-       (\paths conf -> conf { configProgramPaths = paths })--programLocationsSectionDescr :: SectionDescr LegacyPackageConfig-programLocationsSectionDescr =-    SectionDescr {-      sectionName        = "program-locations",-      sectionFields      = programLocationsFieldDescrs,-      sectionSubsections = [],-      sectionGet         = (\x->[("", x)])-                         . legacyConfigureFlags,-      sectionSet         =-        \lineno unused confflags pkgconf -> do-          unless (null unused) $-            syntaxError lineno "the section 'program-locations' takes no arguments"-          return pkgconf {-            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags-          },-      sectionEmpty       = mempty-    }----- | For each known program @PROG@ in 'progDb', produce a @PROG-options@--- 'OptionField'.-programDbOptions-  :: ProgramDb-  -> ShowOrParseArgs-  -> (flags -> [(String, [String])])-  -> ([(String, [String])] -> (flags -> flags))-  -> [OptionField flags]-programDbOptions progDb showOrParseArgs get' set =-  case showOrParseArgs of-    -- we don't want a verbose help text list so we just show a generic one:-    ShowArgs  -> [programOptions  "PROG"]-    ParseArgs -> map (programOptions . programName . fst)-                 (knownPrograms progDb)-  where-    programOptions prog =-      option "" [prog ++ "-options"]-        ("give extra options to " ++ prog)-        get' set-        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])-           (\progArgs -> [ joinsArgs args-                         | (prog', args) <- progArgs, prog==prog' ]))---    joinsArgs = unwords . map escape-    escape arg | any isSpace arg = "\"" ++ arg ++ "\""-               | otherwise       = arg----- The implementation is slight hack: we parse all as remote repository--- but if the url schema is file+noindex, we switch to local.-remoteRepoSectionDescr :: SectionDescr GlobalFlags-remoteRepoSectionDescr = SectionDescr-    { sectionName        = "repository"-    , sectionEmpty       = emptyRemoteRepo (RepoName "")-    , sectionFields      = remoteRepoFields-    , sectionSubsections = []-    , sectionGet         = getS-    , sectionSet         = setS-    }-  where-    getS :: GlobalFlags -> [(String, RemoteRepo)]-    getS gf =-        map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))-        ++-        map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))--    setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags-    setS lineno reponame repo0 conf = do-        repo1 <- postProcessRepo lineno reponame repo0-        case repo1 of-            Left repo -> return conf-                { globalLocalNoIndexRepos  = overNubList (++[repo]) (globalLocalNoIndexRepos conf)-                }-            Right repo -> return conf-                { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)-                }--    localToRemote :: LocalRepo -> RemoteRepo-    localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name)-        { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")-        }------------------------------------ Local field utils------- | Parser combinator for simple fields which uses the field type's--- 'Monoid' instance for combining multiple occurrences of the field.-monoidFieldParsec-    :: Monoid a => String -> (a -> Doc) -> ParsecParser a-    -> (b -> a) -> (a -> b -> b) -> FieldDescr b-monoidFieldParsec name showF readF get' set =-  liftField get' set' $ ParseUtils.fieldParsec name showF readF-  where-    set' xs b = set (get' b `mappend` xs) b-----TODO: [code cleanup] local redefinition that should replace the version in--- D.ParseUtils called showFilePath. This version escapes "." and "--" which--- otherwise are special syntax.-showTokenQ :: String -> Doc-showTokenQ ""            = Disp.empty-showTokenQ x@('-':'-':_) = Disp.text (show x)-showTokenQ x@('.':[])    = Disp.text (show x)-showTokenQ x             = showToken x----- Handy util-addFields :: [FieldDescr a]-          -> ([FieldDescr a] -> [FieldDescr a])-addFields = (++)
− Distribution/Client/ProjectConfig/Types.hs 
@@ -1,458 +0,0 @@-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}---- | Handling project configuration, types.----module Distribution.Client.ProjectConfig.Types (--    -- * Types for project config-    ProjectConfig(..),-    ProjectConfigBuildOnly(..),-    ProjectConfigShared(..),-    ProjectConfigProvenance(..),-    PackageConfig(..),--    -- * Resolving configuration-    SolverSettings(..),-    BuildTimeSettings(..),--    -- * Extra useful Monoids-    MapLast(..),-    MapMappend(..),-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo )-import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) )-import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy )-import Distribution.Client.Dependency.Types-         ( PreSolver )-import Distribution.Client.Targets-         ( UserConstraint )-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import Distribution.Client.Types.SourceRepo (SourceRepoList)--import Distribution.Client.IndexUtils.IndexState-         ( TotalIndexState )-import Distribution.Client.IndexUtils.ActiveRepos-         ( ActiveRepos )--import Distribution.Client.CmdInstall.ClientInstallFlags-         ( ClientInstallFlags(..) )--import Distribution.Solver.Types.Settings-import Distribution.Solver.Types.ConstraintSource--import Distribution.Package-         ( PackageName, PackageId, UnitId )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint )-import Distribution.Version-         ( Version )-import Distribution.System-         ( Platform )-import Distribution.PackageDescription-         ( FlagAssignment )-import Distribution.Simple.Compiler-         ( Compiler, CompilerFlavor-         , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )-import Distribution.Simple.Setup-         ( Flag, HaddockTarget(..), TestShowDetails(..) )-import Distribution.Simple.InstallDirs-         ( PathTemplate )-import Distribution.Utils.NubList-         ( NubList )--import qualified Data.Map as Map------------------------------------ Project config types------- | This type corresponds directly to what can be written in the--- @cabal.project@ file. Other sources of configuration can also be injected--- into this type, such as the user-wide @~/.cabal/config@ file and the--- command line of @cabal configure@ or @cabal build@.------ Since it corresponds to the external project file it is an instance of--- 'Monoid' and all the fields can be empty. This also means there has to--- be a step where we resolve configuration. At a minimum resolving means--- applying defaults but it can also mean merging information from multiple--- sources. For example for package-specific configuration the project file--- can specify configuration that applies to all local packages, and then--- additional configuration for a specific package.------ Future directions: multiple profiles, conditionals. If we add these--- features then the gap between configuration as written in the config file--- and resolved settings we actually use will become even bigger.----data ProjectConfig-   = ProjectConfig {--       -- | Packages in this project, including local dirs, local .cabal files-       -- local and remote tarballs. When these are file globs, they must-       -- match at least one package.-       projectPackages              :: [String],--       -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that-       -- file globs are allowed to match nothing. The primary use case for-       -- this is to be able to say @optional-packages: */@ to automagically-       -- pick up deps that we unpack locally without erroring when-       -- there aren't any.-       projectPackagesOptional      :: [String],--       -- | Packages in this project from remote source repositories.-       projectPackagesRepo          :: [SourceRepoList],--       -- | Packages in this project from hackage repositories.-       projectPackagesNamed         :: [PackageVersionConstraint],--       -- See respective types for an explanation of what these-       -- values are about:-       projectConfigBuildOnly       :: ProjectConfigBuildOnly,-       projectConfigShared          :: ProjectConfigShared,-       projectConfigProvenance      :: Set ProjectConfigProvenance,--       -- | Configuration to be applied to *all* packages,-       -- whether named in `cabal.project` or not.-       projectConfigAllPackages     :: PackageConfig,--       -- | Configuration to be applied to *local* packages; i.e.,-       -- any packages which are explicitly named in `cabal.project`.-       projectConfigLocalPackages   :: PackageConfig,-       projectConfigSpecificPackage :: MapMappend PackageName PackageConfig-     }-  deriving (Eq, Show, Generic, Typeable)---- | That part of the project configuration that only affects /how/ we build--- and not the /value/ of the things we build. This means this information--- does not need to be tracked for changes since it does not affect the--- outcome.----data ProjectConfigBuildOnly-   = ProjectConfigBuildOnly {-       projectConfigVerbosity             :: Flag Verbosity,-       projectConfigDryRun                :: Flag Bool,-       projectConfigOnlyDeps              :: Flag Bool,-       projectConfigSummaryFile           :: NubList PathTemplate,-       projectConfigLogFile               :: Flag PathTemplate,-       projectConfigBuildReports          :: Flag ReportLevel,-       projectConfigReportPlanningFailure :: Flag Bool,-       projectConfigSymlinkBinDir         :: Flag FilePath,-       projectConfigOneShot               :: Flag Bool,-       projectConfigNumJobs               :: Flag (Maybe Int),-       projectConfigKeepGoing             :: Flag Bool,-       projectConfigOfflineMode           :: Flag Bool,-       projectConfigKeepTempFiles         :: Flag Bool,-       projectConfigHttpTransport         :: Flag String,-       projectConfigIgnoreExpiry          :: Flag Bool,-       projectConfigCacheDir              :: Flag FilePath,-       projectConfigLogsDir               :: Flag FilePath,-       projectConfigClientInstallFlags    :: ClientInstallFlags-     }-  deriving (Eq, Show, Generic)----- | Project configuration that is shared between all packages in the project.--- In particular this includes configuration that affects the solver.----data ProjectConfigShared-   = ProjectConfigShared {-       projectConfigDistDir           :: Flag FilePath,-       projectConfigConfigFile        :: Flag FilePath,-       projectConfigProjectFile       :: Flag FilePath,-       projectConfigIgnoreProject     :: Flag Bool,-       projectConfigHcFlavor          :: Flag CompilerFlavor,-       projectConfigHcPath            :: Flag FilePath,-       projectConfigHcPkg             :: Flag FilePath,-       projectConfigHaddockIndex      :: Flag PathTemplate,--       -- Things that only make sense for manual mode, not --local mode-       -- too much control!-     --projectConfigUserInstall       :: Flag Bool,-     --projectConfigInstallDirs       :: InstallDirs (Flag PathTemplate),-     --TODO: [required eventually] decide what to do with InstallDirs-     -- currently we don't allow it to be specified in the config file-     --projectConfigPackageDBs        :: [Maybe PackageDB],--       -- configuration used both by the solver and other phases-       projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.-       projectConfigLocalNoIndexRepos :: NubList LocalRepo,-       projectConfigActiveRepos       :: Flag ActiveRepos,-       projectConfigIndexState        :: Flag TotalIndexState,-       projectConfigStoreDir          :: Flag FilePath,--       -- solver configuration-       projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],-       projectConfigPreferences       :: [PackageVersionConstraint],-       projectConfigCabalVersion      :: Flag Version,  --TODO: [required eventually] unused-       projectConfigSolver            :: Flag PreSolver,-       projectConfigAllowOlder        :: Maybe AllowOlder,-       projectConfigAllowNewer        :: Maybe AllowNewer,-       projectConfigWriteGhcEnvironmentFilesPolicy-                                      :: Flag WriteGhcEnvironmentFilesPolicy,-       projectConfigMaxBackjumps      :: Flag Int,-       projectConfigReorderGoals      :: Flag ReorderGoals,-       projectConfigCountConflicts    :: Flag CountConflicts,-       projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts,-       projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet,-       projectConfigStrongFlags       :: Flag StrongFlags,-       projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls,-       projectConfigOnlyConstrained   :: Flag OnlyConstrained,-       projectConfigPerComponent      :: Flag Bool,-       projectConfigIndependentGoals  :: Flag IndependentGoals,--       projectConfigProgPathExtra     :: NubList FilePath--       -- More things that only make sense for manual mode, not --local mode-       -- too much control!-     --projectConfigShadowPkgs        :: Flag Bool,-     --projectConfigReinstall         :: Flag Bool,-     --projectConfigAvoidReinstalls   :: Flag Bool,-     --projectConfigOverrideReinstall :: Flag Bool,-     --projectConfigUpgradeDeps       :: Flag Bool-     }-  deriving (Eq, Show, Generic)----- | Specifies the provenance of project configuration, whether defaults were--- used or if the configuration was read from an explicit file path.-data ProjectConfigProvenance--     -- | The configuration is implicit due to no explicit configuration-     -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig'-     -- for how implicit configuration is determined.-   = Implicit--     -- | The path the project configuration was explicitly read from.-     -- | The configuration was explicitly read from the specified 'FilePath'.-   | Explicit FilePath-  deriving (Eq, Ord, Show, Generic)----- | Project configuration that is specific to each package, that is where we--- can in principle have different values for different packages in the same--- project.----data PackageConfig-   = PackageConfig {-       packageConfigProgramPaths        :: MapLast String FilePath,-       packageConfigProgramArgs         :: MapMappend String [String],-       packageConfigProgramPathExtra    :: NubList FilePath,-       packageConfigFlagAssignment      :: FlagAssignment,-       packageConfigVanillaLib          :: Flag Bool,-       packageConfigSharedLib           :: Flag Bool,-       packageConfigStaticLib           :: Flag Bool,-       packageConfigDynExe              :: Flag Bool,-       packageConfigFullyStaticExe      :: Flag Bool,-       packageConfigProf                :: Flag Bool, --TODO: [code cleanup] sort out-       packageConfigProfLib             :: Flag Bool, --      this duplication-       packageConfigProfExe             :: Flag Bool, --      and consistency-       packageConfigProfDetail          :: Flag ProfDetailLevel,-       packageConfigProfLibDetail       :: Flag ProfDetailLevel,-       packageConfigConfigureArgs       :: [String],-       packageConfigOptimization        :: Flag OptimisationLevel,-       packageConfigProgPrefix          :: Flag PathTemplate,-       packageConfigProgSuffix          :: Flag PathTemplate,-       packageConfigExtraLibDirs        :: [FilePath],-       packageConfigExtraFrameworkDirs  :: [FilePath],-       packageConfigExtraIncludeDirs    :: [FilePath],-       packageConfigGHCiLib             :: Flag Bool,-       packageConfigSplitSections       :: Flag Bool,-       packageConfigSplitObjs           :: Flag Bool,-       packageConfigStripExes           :: Flag Bool,-       packageConfigStripLibs           :: Flag Bool,-       packageConfigTests               :: Flag Bool,-       packageConfigBenchmarks          :: Flag Bool,-       packageConfigCoverage            :: Flag Bool,-       packageConfigRelocatable         :: Flag Bool,-       packageConfigDebugInfo           :: Flag DebugInfoLevel,-       packageConfigRunTests            :: Flag Bool, --TODO: [required eventually] use this-       packageConfigDocumentation       :: Flag Bool, --TODO: [required eventually] use this-       -- Haddock options-       packageConfigHaddockHoogle       :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockHtml         :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this-       packageConfigHaddockForeignLibs  :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockExecutables  :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockTestSuites   :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockBenchmarks   :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockInternal     :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockCss          :: Flag FilePath, --TODO: [required eventually] use this-       packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockQuickJump    :: Flag Bool, --TODO: [required eventually] use this-       packageConfigHaddockHscolourCss  :: Flag FilePath, --TODO: [required eventually] use this-       packageConfigHaddockContents     :: Flag PathTemplate, --TODO: [required eventually] use this-       packageConfigHaddockForHackage   :: Flag HaddockTarget,-       -- Test options-       packageConfigTestHumanLog        :: Flag PathTemplate,-       packageConfigTestMachineLog      :: Flag PathTemplate,-       packageConfigTestShowDetails     :: Flag TestShowDetails,-       packageConfigTestKeepTix         :: Flag Bool,-       packageConfigTestWrapper         :: Flag FilePath,-       packageConfigTestFailWhenNoTestSuites :: Flag Bool,-       packageConfigTestTestOptions     :: [PathTemplate],-       -- Benchmark options-       packageConfigBenchmarkOptions    :: [PathTemplate]-     }-  deriving (Eq, Show, Generic)--instance Binary ProjectConfig-instance Binary ProjectConfigBuildOnly-instance Binary ProjectConfigShared-instance Binary ProjectConfigProvenance-instance Binary PackageConfig--instance Structured ProjectConfig-instance Structured ProjectConfigBuildOnly-instance Structured ProjectConfigShared-instance Structured ProjectConfigProvenance-instance Structured PackageConfig---- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes--- the last value rather than the first value for overlapping keys.-newtype MapLast k v = MapLast { getMapLast :: Map k v }-  deriving (Eq, Show, Functor, Generic, Binary, Typeable)--instance (Structured k, Structured v) => Structured (MapLast k v)--instance Ord k => Monoid (MapLast k v) where-  mempty  = MapLast Map.empty-  mappend = (<>)--instance Ord k => Semigroup (MapLast k v) where-  MapLast a <> MapLast b = MapLast $ Map.union b a-  -- rather than Map.union which is the normal Map monoid instance----- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that--- 'mappend's values of overlapping keys rather than taking the first.-newtype MapMappend k v = MapMappend { getMapMappend :: Map k v }-  deriving (Eq, Show, Functor, Generic, Binary, Typeable)--instance (Structured k, Structured v) => Structured (MapMappend k v)--instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where-  mempty  = MapMappend Map.empty-  mappend = (<>)--instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where-  MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b)-  -- rather than Map.union which is the normal Map monoid instance---instance Monoid ProjectConfig where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ProjectConfig where-  (<>) = gmappend---instance Monoid ProjectConfigBuildOnly where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ProjectConfigBuildOnly where-  (<>) = gmappend---instance Monoid ProjectConfigShared where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ProjectConfigShared where-  (<>) = gmappend---instance Monoid PackageConfig where-  mempty = gmempty-  mappend = (<>)--instance Semigroup PackageConfig where-  (<>) = gmappend--------------------------------------------- Resolving configuration to settings------- | Resolved configuration for the solver. The idea is that this is easier to--- use than the raw configuration because in the raw configuration everything--- is optional (monoidial). In the 'BuildTimeSettings' every field is filled--- in, if only with the defaults.------ Use 'resolveSolverSettings' to make one from the project config (by--- applying defaults etc).----data SolverSettings-   = SolverSettings {-       solverSettingRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.-       solverSettingLocalNoIndexRepos :: [LocalRepo],-       solverSettingConstraints       :: [(UserConstraint, ConstraintSource)],-       solverSettingPreferences       :: [PackageVersionConstraint],-       solverSettingFlagAssignment    :: FlagAssignment, -- ^ For all local packages-       solverSettingFlagAssignments   :: Map PackageName FlagAssignment,-       solverSettingCabalVersion      :: Maybe Version,  --TODO: [required eventually] unused-       solverSettingSolver            :: PreSolver,-       solverSettingAllowOlder        :: AllowOlder,-       solverSettingAllowNewer        :: AllowNewer,-       solverSettingMaxBackjumps      :: Maybe Int,-       solverSettingReorderGoals      :: ReorderGoals,-       solverSettingCountConflicts    :: CountConflicts,-       solverSettingFineGrainedConflicts :: FineGrainedConflicts,-       solverSettingMinimizeConflictSet :: MinimizeConflictSet,-       solverSettingStrongFlags       :: StrongFlags,-       solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,-       solverSettingOnlyConstrained   :: OnlyConstrained,-       solverSettingIndexState        :: Maybe TotalIndexState,-       solverSettingActiveRepos       :: Maybe ActiveRepos,-       solverSettingIndependentGoals  :: IndependentGoals-       -- Things that only make sense for manual mode, not --local mode-       -- too much control!-     --solverSettingShadowPkgs        :: Bool,-     --solverSettingReinstall         :: Bool,-     --solverSettingAvoidReinstalls   :: Bool,-     --solverSettingOverrideReinstall :: Bool,-     --solverSettingUpgradeDeps       :: Bool-     }-  deriving (Eq, Show, Generic, Typeable)--instance Binary SolverSettings-instance Structured SolverSettings----- | Resolved configuration for things that affect how we build and not the--- value of the things we build. The idea is that this is easier to use than--- the raw configuration because in the raw configuration everything is--- optional (monoidial). In the 'BuildTimeSettings' every field is filled in,--- if only with the defaults.------ Use 'resolveBuildTimeSettings' to make one from the project config (by--- applying defaults etc).----data BuildTimeSettings-   = BuildTimeSettings {-       buildSettingDryRun                :: Bool,-       buildSettingOnlyDeps              :: Bool,-       buildSettingSummaryFile           :: [PathTemplate],-       buildSettingLogFile               :: Maybe (Compiler  -> Platform-                                                -> PackageId -> UnitId-                                                             -> FilePath),-       buildSettingLogVerbosity          :: Verbosity,-       buildSettingBuildReports          :: ReportLevel,-       buildSettingReportPlanningFailure :: Bool,-       buildSettingSymlinkBinDir         :: [FilePath],-       buildSettingOneShot               :: Bool,-       buildSettingNumJobs               :: Int,-       buildSettingKeepGoing             :: Bool,-       buildSettingOfflineMode           :: Bool,-       buildSettingKeepTempFiles         :: Bool,-       buildSettingRemoteRepos           :: [RemoteRepo],-       buildSettingLocalNoIndexRepos     :: [LocalRepo],-       buildSettingCacheDir              :: FilePath,-       buildSettingHttpTransport         :: Maybe String,-       buildSettingIgnoreExpiry          :: Bool,-       buildSettingProgPathExtra         :: [FilePath]-     }
− Distribution/Client/ProjectFlags.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-module Distribution.Client.ProjectFlags (-    ProjectFlags(..),-    defaultProjectFlags,-    projectFlagsOptions,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.ReadE          (succeedReadE)-import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg)-import Distribution.Simple.Setup   (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)--data ProjectFlags = ProjectFlags-    { flagProjectFileName :: Flag FilePath-      -- ^ The cabal project file name; defaults to @cabal.project@.-      -- The name itself denotes the cabal project file name, but it also-      -- is the base of auxiliary project files, such as-      -- @cabal.project.local@ and @cabal.project.freeze@ which are also-      -- read and written out in some cases.  If the path is not found-      -- in the current working directory, we will successively probe-      -- relative to parent directories until this name is found.--    , flagIgnoreProject   :: Flag Bool-      -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)-      -- The exact interpretation might be slightly different per command.-    }-  deriving (Show, Generic)--defaultProjectFlags :: ProjectFlags-defaultProjectFlags = ProjectFlags-    { flagProjectFileName = mempty-    , flagIgnoreProject   = toFlag False-      -- Should we use 'Last' here?-    }--projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]-projectFlagsOptions showOrParseArgs =-    [ option [] ["project-file"]-        "Set the name of the cabal.project file to search for in parent directories"-        flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf })-        (reqArg "FILE" (succeedReadE Flag) flagToList)-    , option ['z'] ["ignore-project"]-        "Ignore local project configuration"-        flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v })-        (yesNoOpt showOrParseArgs)-    ]--instance Monoid ProjectFlags where-    mempty = gmempty-    mappend = (<>)--instance Semigroup ProjectFlags where-    (<>) = gmappend--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
− Distribution/Client/ProjectOrchestration.hs 
@@ -1,1255 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}---- | This module deals with building and incrementally rebuilding a collection--- of packages. It is what backs the @cabal build@ and @configure@ commands,--- as well as being a core part of @run@, @test@, @bench@ and others.------ The primary thing is in fact rebuilding (and trying to make that quick by--- not redoing unnecessary work), so building from scratch is just a special--- case.------ The build process and the code can be understood by breaking it down into--- three major parts:------ * The 'ElaboratedInstallPlan' type------ * The \"what to do\" phase, where we look at the all input configuration---   (project files, .cabal files, command line etc) and produce a detailed---   plan of what to do -- the 'ElaboratedInstallPlan'.------ * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we--- re-execute it.------ As far as possible, the \"what to do\" phase embodies all the policy, leaving--- the \"do it\" phase policy free. The first phase contains more of the--- complicated logic, but it is contained in code that is either pure or just--- has read effects (except cache updates). Then the second phase does all the--- actions to build packages, but as far as possible it just follows the--- instructions and avoids any logic for deciding what to do (apart from--- recompilation avoidance in executing the plan).------ This division helps us keep the code under control, making it easier to--- understand, test and debug. So when you are extending these modules, please--- think about which parts of your change belong in which part. It is--- perfectly ok to extend the description of what to do (i.e. the--- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the--- first phase. Also, the second phase does not have direct access to any of--- the input configuration anyway; all the information has to flow via the--- 'ElaboratedInstallPlan'.----module Distribution.Client.ProjectOrchestration (-    -- * Discovery phase: what is in the project?-    CurrentCommand(..),-    establishProjectBaseContext,-    establishProjectBaseContextWithRoot,-    ProjectBaseContext(..),-    BuildTimeSettings(..),-    commandLineFlagsToProjectConfig,--    -- * Pre-build phase: decide what to do.-    withInstallPlan,-    runProjectPreBuildPhase,-    ProjectBuildContext(..),--    -- ** Selecting what targets we mean-    readTargetSelectors,-    reportTargetSelectorProblems,-    resolveTargets,-    TargetsMap,-    TargetSelector(..),-    TargetImplicitCwd(..),-    PackageId,-    AvailableTarget(..),-    AvailableTargetStatus(..),-    TargetRequested(..),-    ComponentName(..),-    ComponentKind(..),-    ComponentTarget(..),-    SubComponentTarget(..),-    selectComponentTargetBasic,-    distinctTargetComponents,-    -- ** Utils for selecting targets-    filterTargetsKind,-    filterTargetsKindWith,-    selectBuildableTargets,-    selectBuildableTargetsWith,-    selectBuildableTargets',-    selectBuildableTargetsWith',-    forgetTargetsDetail,--    -- ** Adjusting the plan-    pruneInstallPlanToTargets,-    TargetAction(..),-    pruneInstallPlanToDependencies,-    CannotPruneDependencies(..),-    printPlan,--    -- * Build phase: now do it.-    runProjectBuildPhase,--    -- * Post build actions-    runProjectPostBuildPhase,-    dieOnBuildFailures,--    -- * Dummy projects-    establishDummyProjectBaseContext,-    establishDummyDistDirLayout,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Distribution.Compat.Directory-         ( makeAbsolute )--import           Distribution.Client.ProjectConfig-import           Distribution.Client.ProjectPlanning-                   hiding ( pruneInstallPlanToTargets )-import qualified Distribution.Client.ProjectPlanning as ProjectPlanning-                   ( pruneInstallPlanToTargets )-import           Distribution.Client.ProjectPlanning.Types-import           Distribution.Client.ProjectBuilding-import           Distribution.Client.ProjectPlanOutput-import           Distribution.Client.RebuildMonad ( runRebuild )--import           Distribution.Client.TargetProblem-                   ( TargetProblem (..) )-import           Distribution.Client.Types-                   ( GenericReadyPackage(..), UnresolvedSourcePackage-                   , PackageSpecifier(..)-                   , SourcePackageDb(..)-                   , WriteGhcEnvironmentFilesPolicy(..) )-import           Distribution.Solver.Types.PackageIndex-                   ( lookupPackageName )-import qualified Distribution.Client.InstallPlan as InstallPlan-import           Distribution.Client.TargetSelector-                   ( TargetSelector(..), TargetImplicitCwd(..)-                   , ComponentKind(..), componentKind-                   , readTargetSelectors, reportTargetSelectorProblems )-import           Distribution.Client.DistDirLayout-import           Distribution.Client.Config (getCabalDir)-import           Distribution.Client.Setup hiding (packageName)-import           Distribution.Compiler-                   ( CompilerFlavor(GHC) )-import           Distribution.Types.ComponentName-                   ( componentNameString )-import           Distribution.Types.UnqualComponentName-                   ( UnqualComponentName, packageNameToUnqualComponentName )--import           Distribution.Solver.Types.OptionalStanza--import           Distribution.Package-import           Distribution.Types.Flag-                   ( FlagAssignment, showFlagAssignment, diffFlagAssignment )-import           Distribution.Simple.LocalBuildInfo-                   ( ComponentName(..), pkgComponents )-import           Distribution.Simple.Flag-                   ( fromFlagOrDefault, flagToMaybe )-import qualified Distribution.Simple.Setup as Setup-import           Distribution.Simple.Command (commandShowOptions)-import           Distribution.Simple.Configure (computeEffectiveProfiling)--import           Distribution.Simple.Utils-                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose )-import           Distribution.Verbosity-import           Distribution.Version-                   ( mkVersion )-import           Distribution.Simple.Compiler-                   ( compilerCompatVersion, showCompilerId-                   , OptimisationLevel(..))--import qualified Data.List.NonEmpty as NE-import qualified Data.Set as Set-import qualified Data.Map as Map-import           Control.Exception (assert)-#ifdef MIN_VERSION_unix-import           System.Posix.Signals (sigKILL, sigSEGV)-#endif----- | Tracks what command is being executed, because we need to hide this somewhere--- for cases that need special handling (usually for error reporting).-data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand-                    deriving (Show, Eq)---- | This holds the context of a project prior to solving: the content of the--- @cabal.project@ and all the local package @.cabal@ files.----data ProjectBaseContext = ProjectBaseContext {-       distDirLayout  :: DistDirLayout,-       cabalDirLayout :: CabalDirLayout,-       projectConfig  :: ProjectConfig,-       localPackages  :: [PackageSpecifier UnresolvedSourcePackage],-       buildSettings  :: BuildTimeSettings,-       currentCommand :: CurrentCommand-     }--establishProjectBaseContext-    :: Verbosity-    -> ProjectConfig-    -> CurrentCommand-    -> IO ProjectBaseContext-establishProjectBaseContext verbosity cliConfig currentCommand = do-    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile-    establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand-  where-    mprojectFile   = Setup.flagToMaybe projectConfigProjectFile-    ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig---- | Like 'establishProjectBaseContext' but doesn't search for project root.-establishProjectBaseContextWithRoot-    :: Verbosity-    -> ProjectConfig-    -> ProjectRoot-    -> CurrentCommand-    -> IO ProjectBaseContext-establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do-    cabalDir <- getCabalDir--    let distDirLayout  = defaultDistDirLayout projectRoot mdistDirectory--    (projectConfig, localPackages) <--      rebuildProjectConfig verbosity-                           distDirLayout-                           cliConfig--    let ProjectConfigBuildOnly {-          projectConfigLogsDir-        } = projectConfigBuildOnly projectConfig--        ProjectConfigShared {-          projectConfigStoreDir-        } = projectConfigShared projectConfig--        mlogsDir = Setup.flagToMaybe projectConfigLogsDir-    mstoreDir <- sequenceA $ makeAbsolute-                 <$> Setup.flagToMaybe projectConfigStoreDir-    let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir--        buildSettings = resolveBuildTimeSettings-                          verbosity cabalDirLayout-                          projectConfig--    -- https://github.com/haskell/cabal/issues/6013-    when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $-        warn verbosity "There are no packages or optional-packages in the project"--    return ProjectBaseContext {-      distDirLayout,-      cabalDirLayout,-      projectConfig,-      localPackages,-      buildSettings,-      currentCommand-    }-  where-    mdistDirectory = Setup.flagToMaybe projectConfigDistDir-    ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig----- | This holds the context between the pre-build, build and post-build phases.----data ProjectBuildContext = ProjectBuildContext {-      -- | This is the improved plan, before we select a plan subset based on-      -- the build targets, and before we do the dry-run. So this contains-      -- all packages in the project.-      elaboratedPlanOriginal :: ElaboratedInstallPlan,--      -- | This is the 'elaboratedPlanOriginal' after we select a plan subset-      -- and do the dry-run phase to find out what is up-to or out-of date.-      -- This is the plan that will be executed during the build phase. So-      -- this contains only a subset of packages in the project.-      elaboratedPlanToExecute:: ElaboratedInstallPlan,--      -- | The part of the install plan that's shared between all packages in-      -- the plan. This does not change between the two plan variants above,-      -- so there is just the one copy.-      elaboratedShared       :: ElaboratedSharedConfig,--      -- | The result of the dry-run phase. This tells us about each member of-      -- the 'elaboratedPlanToExecute'.-      pkgsBuildStatus        :: BuildStatusMap,--      -- | The targets selected by @selectPlanSubset@. This is useful eg. in-      -- CmdRun, where we need a valid target to execute.-      targetsMap             :: TargetsMap-    }----- | Pre-build phase: decide what to do.----withInstallPlan-    :: Verbosity-    -> ProjectBaseContext-    -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)-    -> IO a-withInstallPlan-    verbosity-    ProjectBaseContext {-      distDirLayout,-      cabalDirLayout,-      projectConfig,-      localPackages-    }-    action = do-    -- Take the project configuration and make a plan for how to build-    -- everything in the project. This is independent of any specific targets-    -- the user has asked for.-    ---    (elaboratedPlan, _, elaboratedShared, _, _) <--      rebuildInstallPlan verbosity-                         distDirLayout cabalDirLayout-                         projectConfig-                         localPackages-    action elaboratedPlan elaboratedShared--runProjectPreBuildPhase-    :: Verbosity-    -> ProjectBaseContext-    -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))-    -> IO ProjectBuildContext-runProjectPreBuildPhase-    verbosity-    ProjectBaseContext {-      distDirLayout,-      cabalDirLayout,-      projectConfig,-      localPackages-    }-    selectPlanSubset = do-    -- Take the project configuration and make a plan for how to build-    -- everything in the project. This is independent of any specific targets-    -- the user has asked for.-    ---    (elaboratedPlan, _, elaboratedShared, _, _) <--      rebuildInstallPlan verbosity-                         distDirLayout cabalDirLayout-                         projectConfig-                         localPackages--    -- The plan for what to do is represented by an 'ElaboratedInstallPlan'--    -- Now given the specific targets the user has asked for, decide-    -- which bits of the plan we will want to execute.-    ---    (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan--    -- Check which packages need rebuilding.-    -- This also gives us more accurate reasons for the --dry-run output.-    ---    pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared-                                            elaboratedPlan'--    -- Improve the plan by marking up-to-date packages as installed.-    ---    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages-                             pkgsBuildStatus elaboratedPlan'-    debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')--    return ProjectBuildContext {-      elaboratedPlanOriginal = elaboratedPlan,-      elaboratedPlanToExecute = elaboratedPlan'',-      elaboratedShared,-      pkgsBuildStatus,-      targetsMap = targets-    }----- | Build phase: now do it.------ Execute all or parts of the description of what to do to build or--- rebuild the various packages needed.----runProjectBuildPhase :: Verbosity-                     -> ProjectBaseContext-                     -> ProjectBuildContext-                     -> IO BuildOutcomes-runProjectBuildPhase _ ProjectBaseContext{buildSettings} _-  | buildSettingDryRun buildSettings-  = return Map.empty--runProjectBuildPhase verbosity-                     ProjectBaseContext{..} ProjectBuildContext {..} =-    fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $-    rebuildTargets verbosity-                   distDirLayout-                   (cabalStoreDirLayout cabalDirLayout)-                   elaboratedPlanToExecute-                   elaboratedShared-                   pkgsBuildStatus-                   buildSettings-  where-    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes-    previousBuildOutcomes =-      Map.mapMaybe $ \status -> case status of-        BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)-        --TODO: [nice to have] record build failures persistently-        _                                  -> Nothing---- | Post-build phase: various administrative tasks------ Update bits of state based on the build outcomes and report any failures.----runProjectPostBuildPhase :: Verbosity-                         -> ProjectBaseContext-                         -> ProjectBuildContext-                         -> BuildOutcomes-                         -> IO ()-runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _-  | buildSettingDryRun buildSettings-  = return ()--runProjectPostBuildPhase verbosity-                         ProjectBaseContext {..} ProjectBuildContext {..}-                         buildOutcomes = do-    -- Update other build artefacts-    -- TODO: currently none, but could include:-    --        - bin symlinks/wrappers-    --        - haddock/hoogle/ctags indexes-    --        - delete stale lib registrations-    --        - delete stale package dirs--    postBuildStatus <- updatePostBuildProjectStatus-                         verbosity-                         distDirLayout-                         elaboratedPlanOriginal-                         pkgsBuildStatus-                         buildOutcomes--    -- Write the .ghc.environment file (if allowed by the env file write policy).-    let writeGhcEnvFilesPolicy =-          projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared-          $ projectConfig--        shouldWriteGhcEnvironment =-          case fromFlagOrDefault NeverWriteGhcEnvironmentFiles-               writeGhcEnvFilesPolicy-          of-            AlwaysWriteGhcEnvironmentFiles                -> True-            NeverWriteGhcEnvironmentFiles                 -> False-            WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->-              let compiler         = pkgConfigCompiler elaboratedShared-                  ghcCompatVersion = compilerCompatVersion GHC compiler-              in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion--    when shouldWriteGhcEnvironment $-      void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout)-                                     elaboratedPlanOriginal-                                     elaboratedShared-                                     postBuildStatus--    -- Finally if there were any build failures then report them and throw-    -- an exception to terminate the program-    dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes--    -- Note that it is a deliberate design choice that the 'buildTargets' is-    -- not passed to phase 1, and the various bits of input config is not-    -- passed to phase 2.-    ---    -- We make the install plan without looking at the particular targets the-    -- user asks us to build. The set of available things we can build is-    -- discovered from the env and config and is used to make the install plan.-    -- The targets just tell us which parts of the install plan to execute.-    ---    -- Conversely, executing the plan does not directly depend on any of the-    -- input config. The bits that are needed (or better, the decisions based-    -- on it) all go into the install plan.--    -- Notionally, the 'BuildFlags' should be things that do not affect what-    -- we build, just how we do it. These ones of course do------------------------------------------------------------------------------------ Taking targets into account, selecting what to build------- | The set of components to build, represented as a mapping from 'UnitId's--- to the 'ComponentTarget's within the unit that will be selected--- (e.g. selected to build, test or repl).------ Associated with each 'ComponentTarget' is the set of 'TargetSelector's that--- matched this target. Typically this is exactly one, but in general it is--- possible to for different selectors to match the same target. This extra--- information is primarily to help make helpful error messages.----type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])]---- | Given a set of 'TargetSelector's, resolve which 'UnitId's and--- 'ComponentTarget's they ought to refer to.------ The idea is that every user target identifies one or more roots in the--- 'ElaboratedInstallPlan', which we will use to determine the closure--- of what packages need to be built, dropping everything from the plan--- that is unnecessary. This closure and pruning is done by--- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms--- of 'UnitId's and the 'ComponentTarget's within those.------ This means we first need to translate the 'TargetSelector's into the--- 'UnitId's and 'ComponentTarget's. This translation has to be different for--- the different command line commands, like @build@, @repl@ etc. For example--- the command @build pkgfoo@ could select a different set of components in--- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and--- all executables, whereas @repl@ would select the library or a single--- executable. Furthermore, both of these examples could fail, and fail in--- different ways and each needs to be able to produce helpful error messages.------ So 'resolveTargets' takes two helpers: one to select the targets to be used--- by user targets that refer to a whole package ('TargetPackage'), and--- another to check user targets that refer to a component (or a module or--- file within a component). These helpers can fail, and use their own error--- type. Both helpers get given the 'AvailableTarget' info about the--- component(s).------ While commands vary quite a bit in their behaviour about which components to--- select for a whole-package target, most commands have the same behaviour for--- checking a user target that refers to a specific component. To help with--- this commands can use 'selectComponentTargetBasic', either directly or as--- a basis for their own @selectComponentTarget@ implementation.----resolveTargets :: forall err.-                  (forall k. TargetSelector-                          -> [AvailableTarget k]-                          -> Either (TargetProblem err) [k])-               -> (forall k. SubComponentTarget-                          -> AvailableTarget k-                          -> Either (TargetProblem err)  k )-               -> ElaboratedInstallPlan-               -> Maybe (SourcePackageDb)-               -> [TargetSelector]-               -> Either [TargetProblem err] TargetsMap-resolveTargets selectPackageTargets selectComponentTarget-               installPlan mPkgDb =-      fmap mkTargetsMap-    . either (Left . toList) Right-    . checkErrors-    . map (\ts -> (,) ts <$> checkTarget ts)-  where-    mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])]-                 -> TargetsMap-    mkTargetsMap targets =-        Map.map nubComponentTargets-      $ Map.fromListWith (++)-          [ (uid, [(ct, ts)])-          | (ts, cts) <- targets-          , (uid, ct) <- cts ]--    AvailableTargetIndexes{..} = availableTargetIndexes installPlan--    checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]--    -- We can ask to build any whole package, project-local or a dependency-    checkTarget bt@(TargetPackage _ [pkgid] mkfilter)-      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)-                  $ Map.lookup pkgid availableTargetsByPackageId-      = fmap (componentTargets WholeComponent)-      $ selectPackageTargets bt ats--      | otherwise-      = Left (TargetProblemNoSuchPackage pkgid)--    checkTarget (TargetPackage _ pkgids _)-      = error ("TODO: add support for multiple packages in a directory.  Got\n"-              ++ unlines (map prettyShow pkgids))-      -- For the moment this error cannot happen here, because it gets-      -- detected when the package config is being constructed. This case-      -- will need handling properly when we do add support.-      ---      -- TODO: how should this use case play together with the-      -- '--cabal-file' option of 'configure' which allows using multiple-      -- .cabal files for a single package?--    checkTarget bt@(TargetAllPackages mkfilter) =-        fmap (componentTargets WholeComponent)-      . selectPackageTargets bt-      . maybe id filterTargetsKind mkfilter-      . filter availableTargetLocalToProject-      $ concat (Map.elems availableTargetsByPackageId)--    checkTarget (TargetComponent pkgid cname subtarget)-      | Just ats <- Map.lookup (pkgid, cname)-                               availableTargetsByPackageIdAndComponentName-      = fmap (componentTargets subtarget)-      $ selectComponentTargets subtarget ats--      | Map.member pkgid availableTargetsByPackageId-      = Left (TargetProblemNoSuchComponent pkgid cname)--      | otherwise-      = Left (TargetProblemNoSuchPackage pkgid)--    checkTarget (TargetComponentUnknown pkgname ecname subtarget)-      | Just ats <- case ecname of-          Left ucname ->-            Map.lookup (pkgname, ucname)-                       availableTargetsByPackageNameAndUnqualComponentName-          Right cname ->-            Map.lookup (pkgname, cname)-                       availableTargetsByPackageNameAndComponentName-      = fmap (componentTargets subtarget)-      $ selectComponentTargets subtarget ats--      | Map.member pkgname availableTargetsByPackageName-      = Left (TargetProblemUnknownComponent pkgname ecname)--      | otherwise-      = Left (TargetNotInProject pkgname)--    checkTarget bt@(TargetPackageNamed pkgname mkfilter)-      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)-                  $ Map.lookup pkgname availableTargetsByPackageName-      = fmap (componentTargets WholeComponent)-      . selectPackageTargets bt-      $ ats--      | Just SourcePackageDb{ packageIndex } <- mPkgDb-      , let pkg = lookupPackageName packageIndex pkgname-      , not (null pkg)-      = Left (TargetAvailableInIndex pkgname)--      | otherwise-      = Left (TargetNotInProject pkgname)--    componentTargets :: SubComponentTarget-                     -> [(b, ComponentName)]-                     -> [(b, ComponentTarget)]-    componentTargets subtarget =-      map (fmap (\cname -> ComponentTarget cname subtarget))--    selectComponentTargets :: SubComponentTarget-                           -> [AvailableTarget k]-                           -> Either (TargetProblem err) [k]-    selectComponentTargets subtarget =-        either (Left . NE.head) Right-      . checkErrors-      . map (selectComponentTarget subtarget)--    checkErrors :: [Either e a] -> Either (NonEmpty e) [a]-    checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') })-                . partitionEithers---data AvailableTargetIndexes = AvailableTargetIndexes {-       availableTargetsByPackageIdAndComponentName-         :: AvailableTargetsMap (PackageId, ComponentName),--       availableTargetsByPackageId-         :: AvailableTargetsMap PackageId,--       availableTargetsByPackageName-         :: AvailableTargetsMap PackageName,--       availableTargetsByPackageNameAndComponentName-         :: AvailableTargetsMap (PackageName, ComponentName),--       availableTargetsByPackageNameAndUnqualComponentName-         :: AvailableTargetsMap (PackageName, UnqualComponentName)-     }-type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]---- We define a bunch of indexes to help 'resolveTargets' with resolving--- 'TargetSelector's to specific 'UnitId's.------ They are all derived from the 'availableTargets' index.--- The 'availableTargetsByPackageIdAndComponentName' is just that main index,--- while the others are derived by re-grouping on the index key.------ They are all constructed lazily because they are not necessarily all used.----availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes-availableTargetIndexes installPlan = AvailableTargetIndexes{..}-  where-    availableTargetsByPackageIdAndComponentName =-      availableTargets installPlan--    availableTargetsByPackageId =-                  Map.mapKeysWith-                    (++) (\(pkgid, _cname) -> pkgid)-                    availableTargetsByPackageIdAndComponentName-      `Map.union` availableTargetsEmptyPackages--    availableTargetsByPackageName =-      Map.mapKeysWith-        (++) packageName-        availableTargetsByPackageId--    availableTargetsByPackageNameAndComponentName =-      Map.mapKeysWith-        (++) (\(pkgid, cname) -> (packageName pkgid, cname))-        availableTargetsByPackageIdAndComponentName--    availableTargetsByPackageNameAndUnqualComponentName =-      Map.mapKeysWith-        (++) (\(pkgid, cname) -> let pname  = packageName pkgid-                                     cname' = unqualComponentName pname cname-                                  in (pname, cname'))-        availableTargetsByPackageIdAndComponentName-     where-       unqualComponentName ::-         PackageName -> ComponentName -> UnqualComponentName-       unqualComponentName pkgname =-           fromMaybe (packageNameToUnqualComponentName pkgname)-         . componentNameString--    -- Add in all the empty packages. These do not appear in the-    -- availableTargetsByComponent map, since that only contains-    -- components, so packages with no components are invisible from-    -- that perspective.  The empty packages need to be there for-    -- proper error reporting, so users can select the empty package-    -- and then we can report that it is empty, otherwise we falsely-    -- report there is no such package at all.-    availableTargetsEmptyPackages =-      Map.fromList-        [ (packageId pkg, [])-        | InstallPlan.Configured pkg <- InstallPlan.toList installPlan-        , case elabPkgOrComp pkg of-            ElabComponent _ -> False-            ElabPackage   _ -> null (pkgComponents (elabPkgDescription pkg))-        ]--    --TODO: [research required] what if the solution has multiple-    --      versions of this package?-    --      e.g. due to setup deps or due to multiple independent sets-    --      of packages being built (e.g. ghc + ghcjs in a project)--filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]-filterTargetsKind ckind = filterTargetsKindWith (== ckind)--filterTargetsKindWith :: (ComponentKind -> Bool)-                     -> [AvailableTarget k] -> [AvailableTarget k]-filterTargetsKindWith p ts =-    [ t | t@(AvailableTarget _ cname _ _) <- ts-        , p (componentKind cname) ]--selectBuildableTargets :: [AvailableTarget k] -> [k]-selectBuildableTargets ts =-    [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]--selectBuildableTargetsWith :: (TargetRequested -> Bool)-                          -> [AvailableTarget k] -> [k]-selectBuildableTargetsWith p ts =-    [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]--selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])-selectBuildableTargets' ts =-    (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]-        [ forgetTargetDetail t-        | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ]--selectBuildableTargetsWith' :: (TargetRequested -> Bool)-                           -> [AvailableTarget k] -> ([k], [AvailableTarget ()])-selectBuildableTargetsWith' p ts =-    (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]-        [ forgetTargetDetail t-        | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ]---forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()-forgetTargetDetail = fmap (const ())--forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]-forgetTargetsDetail = map forgetTargetDetail---- | A basic @selectComponentTarget@ implementation to use or pass to--- 'resolveTargets', that does the basic checks that the component is--- buildable and isn't a test suite or benchmark that is disabled. This--- can also be used to do these basic checks as part of a custom impl that----selectComponentTargetBasic :: SubComponentTarget-                           -> AvailableTarget k-                           -> Either (TargetProblem a) k-selectComponentTargetBasic subtarget-                           AvailableTarget {-                             availableTargetPackageId     = pkgid,-                             availableTargetComponentName = cname,-                             availableTargetStatus-                           } =-    case availableTargetStatus of-      TargetDisabledByUser ->-        Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget)--      TargetDisabledBySolver ->-        Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget)--      TargetNotLocal ->-        Left (TargetComponentNotProjectLocal pkgid cname subtarget)--      TargetNotBuildable ->-        Left (TargetComponentNotBuildable pkgid cname subtarget)--      TargetBuildable targetKey _ ->-        Right targetKey---- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts--- for the extra unneeded info in the 'TargetsMap'.----pruneInstallPlanToTargets :: TargetAction -> TargetsMap-                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan-pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =-    assert (Map.size targetsMap > 0) $-    ProjectPlanning.pruneInstallPlanToTargets-      targetActionType-      (Map.map (map fst) targetsMap)-      elaboratedPlan---- | Utility used by repl and run to check if the targets spans multiple--- components, since those commands do not support multiple components.----distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName)-distinctTargetComponents targetsMap =-    Set.fromList [ (uid, cname)-                 | (uid, cts) <- Map.toList targetsMap-                 , (ComponentTarget cname _, _) <- cts ]------------------------------------------------------------------------------------ Displaying what we plan to do------- | Print a user-oriented presentation of the install plan, indicating what--- will be built.----printPlan :: Verbosity-          -> ProjectBaseContext-          -> ProjectBuildContext-          -> IO ()-printPlan verbosity-          ProjectBaseContext {-            buildSettings = BuildTimeSettings{buildSettingDryRun},-            projectConfig = ProjectConfig {-              projectConfigLocalPackages =-                  PackageConfig {packageConfigOptimization}-            }-          }-          ProjectBuildContext {-            elaboratedPlanToExecute = elaboratedPlan,-            elaboratedShared,-            pkgsBuildStatus-          }--  | null pkgs-  = notice verbosity "Up to date"--  | otherwise-  = noticeNoWrap verbosity $ unlines $-      (showBuildProfile ++ "In order, the following "-       ++ wouldWill ++ " be built"-       ++ ifNormal " (use -v for more details)" ++ ":")-    : map showPkgAndReason pkgs--  where-    pkgs = InstallPlan.executionOrder elaboratedPlan--    ifVerbose s | verbosity >= verbose = s-                | otherwise            = ""--    ifNormal s | verbosity >= verbose = ""-               | otherwise            = s--    wouldWill | buildSettingDryRun = "would"-              | otherwise          = "will"--    showPkgAndReason :: ElaboratedReadyPackage -> String-    showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $-      [ " -"-      , if verbosity >= deafening-        then prettyShow (installedUnitId elab)-        else prettyShow (packageId elab)-      , case elabPkgOrComp elab of-          ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)-          ElabComponent comp ->-            "(" ++ showComp elab comp ++ ")"-      , showFlagAssignment (nonDefaultFlags elab)-      , showConfigureFlags elab-      , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab-        in "(" ++ showBuildStatus buildStatus ++ ")"-      ]--    showComp elab comp =-        maybe "custom" prettyShow (compComponentName comp) ++-        if Map.null (elabInstantiatedWith elab)-            then ""-            else " with " ++-                intercalate ", "-                    -- TODO: Abbreviate the UnitIds-                    [ prettyShow k ++ "=" ++ prettyShow v-                    | (k,v) <- Map.toList (elabInstantiatedWith elab) ]--    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment-    nonDefaultFlags elab =-      elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab--    showStanzas pkg = concat-                    $ [ " *test"-                      | TestStanzas  `Set.member` pkgStanzasEnabled pkg ]-                   ++ [ " *bench"-                      | BenchStanzas `Set.member` pkgStanzasEnabled pkg ]--    showTargets elab-      | null (elabBuildTargets elab) = ""-      | otherwise-      = "("-        ++ intercalate ", " [ showComponentTarget (packageId elab) t-                            | t <- elabBuildTargets elab ]-        ++ ")"--    showConfigureFlags elab =-        let fullConfigureFlags-              = setupHsConfigureFlags-                    (ReadyPackage elab)-                    elaboratedShared-                    verbosity-                    "$builddir"-            -- | Given a default value @x@ for a flag, nub @Flag x@-            -- into @NoFlag@.  This gives us a tidier command line-            -- rendering.-            nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a-            nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag-            nubFlag _ f                         = f--            (tryLibProfiling, tryExeProfiling) =-              computeEffectiveProfiling fullConfigureFlags--            partialConfigureFlags-              = mempty {-                configProf    =-                    nubFlag False (configProf fullConfigureFlags),-                configProfExe =-                    nubFlag tryExeProfiling (configProfExe fullConfigureFlags),-                configProfLib =-                    nubFlag tryLibProfiling (configProfLib fullConfigureFlags)-                -- Maybe there are more we can add-              }-        -- Not necessary to "escape" it, it's just for user output-        in unwords . ("":) $-            commandShowOptions-            (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))-            partialConfigureFlags--    showBuildStatus status = case status of-      BuildStatusPreExisting -> "existing package"-      BuildStatusInstalled   -> "already installed"-      BuildStatusDownload {} -> "requires download & build"-      BuildStatusUnpack   {} -> "requires build"-      BuildStatusRebuild _ rebuild -> case rebuild of-        BuildStatusConfigure-          (MonitoredValueChanged _)   -> "configuration changed"-        BuildStatusConfigure mreason  -> showMonitorChangedReason mreason-        BuildStatusBuild _ buildreason -> case buildreason of-          BuildReasonDepsRebuilt      -> "dependency rebuilt"-          BuildReasonFilesChanged-            mreason                   -> showMonitorChangedReason mreason-          BuildReasonExtraTargets _   -> "additional components to build"-          BuildReasonEphemeralTargets -> "ephemeral targets"-      BuildStatusUpToDate {} -> "up to date" -- doesn't happen--    showMonitorChangedReason (MonitoredFileChanged file) =-      "file " ++ file ++ " changed"-    showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"-    showMonitorChangedReason  MonitorFirstRun            = "first run"-    showMonitorChangedReason  MonitorCorruptCache        =-      "cannot read state cache"--    showBuildProfile = "Build profile: " ++ unwords [-      "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,-      "-O" ++  (case packageConfigOptimization of-                Setup.Flag NoOptimisation      -> "0"-                Setup.Flag NormalOptimisation  -> "1"-                Setup.Flag MaximumOptimisation -> "2"-                Setup.NoFlag                   -> "1")]-      ++ "\n"---- | If there are build failures then report them and throw an exception.----dieOnBuildFailures :: Verbosity -> CurrentCommand-                   -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()-dieOnBuildFailures verbosity currentCommand plan buildOutcomes-  | null failures = return ()--  | isSimpleCase  = exitFailure--  | otherwise = do-      -- For failures where we have a build log, print the log plus a header-       sequence_-         [ do notice verbosity $-                '\n' : renderFailureDetail False pkg reason-                    ++ "\nBuild log ( " ++ logfile ++ " ):"-              readFile logfile >>= noticeNoWrap verbosity-         | (pkg, ShowBuildSummaryAndLog reason logfile)-             <- failuresClassification-         ]--       -- For all failures, print either a short summary (if we showed the-       -- build log) or all details-       dieIfNotHaddockFailure verbosity $ unlines-         [ case failureClassification of-             ShowBuildSummaryAndLog reason _-               | verbosity > normal-              -> renderFailureDetail mentionDepOf pkg reason--               | otherwise-              -> renderFailureSummary mentionDepOf pkg reason-              ++ ". See the build log above for details."--             ShowBuildSummaryOnly reason ->-               renderFailureDetail mentionDepOf pkg reason--         | let mentionDepOf = verbosity <= normal-         , (pkg, failureClassification) <- failuresClassification ]-  where-    failures =  [ (pkgid, failure)-                | (pkgid, Left failure) <- Map.toList buildOutcomes ]--    failuresClassification =-      [ (pkg, classifyBuildFailure failure)-      | (pkgid, failure) <- failures-      , case buildFailureReason failure of-          DependentFailed {} -> verbosity > normal-          _                  -> True-      , InstallPlan.Configured pkg <--           maybeToList (InstallPlan.lookup plan pkgid)-      ]--    dieIfNotHaddockFailure-      | currentCommand == HaddockCommand            = die'-      | all isHaddockFailure failuresClassification = warn-      | otherwise                                   = die'-      where-        isHaddockFailure-          (_, ShowBuildSummaryOnly   (HaddocksFailed _)  ) = True-        isHaddockFailure-          (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True-        isHaddockFailure-          _                                                = False---    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation-    classifyBuildFailure BuildFailure {-                           buildFailureReason  = reason,-                           buildFailureLogFile = mlogfile-                         } =-      maybe (ShowBuildSummaryOnly   reason)-            (ShowBuildSummaryAndLog reason) $ do-        logfile <- mlogfile-        e       <- buildFailureException reason-        ExitFailure 1 <- fromException e-        return logfile--    -- Special case: we don't want to report anything complicated in the case-    -- of just doing build on the current package, since it's clear from-    -- context which package failed.-    ---    -- We generalise this rule as follows:-    --  - if only one failure occurs, and it is in a single root-    --    package (i.e. a package with nothing else depending on it)-    --  - and that failure is of a kind that always reports enough-    --    detail itself (e.g. ghc reporting errors on stdout)-    --  - then we do not report additional error detail or context.-    ---    isSimpleCase-      | [(pkgid, failure)] <- failures-      , [pkg]              <- rootpkgs-      , installedUnitId pkg == pkgid-      , isFailureSelfExplanatory (buildFailureReason failure)-      , currentCommand /= InstallCommand-      = True-      | otherwise-      = False--    -- NB: if the Setup script segfaulted or was interrupted,-    -- we should give more detailed information.  So only-    -- assume that exit code 1 is "pedestrian failure."-    isFailureSelfExplanatory (BuildFailed e)-      | Just (ExitFailure 1) <- fromException e = True--    isFailureSelfExplanatory (ConfigureFailed e)-      | Just (ExitFailure 1) <- fromException e = True--    isFailureSelfExplanatory _                  = False--    rootpkgs =-      [ pkg-      | InstallPlan.Configured pkg <- InstallPlan.toList plan-      , hasNoDependents pkg ]--    ultimateDeps pkgid =-        filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)-               (InstallPlan.reverseDependencyClosure plan [pkgid])--    hasNoDependents :: HasUnitId pkg => pkg -> Bool-    hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId--    renderFailureDetail mentionDepOf pkg reason =-        renderFailureSummary mentionDepOf pkg reason ++ "."-     ++ renderFailureExtraDetail reason-     ++ maybe "" showException (buildFailureException reason)--    renderFailureSummary mentionDepOf pkg reason =-        case reason of-          DownloadFailed  _ -> "Failed to download " ++ pkgstr-          UnpackFailed    _ -> "Failed to unpack "   ++ pkgstr-          ConfigureFailed _ -> "Failed to build "    ++ pkgstr-          BuildFailed     _ -> "Failed to build "    ++ pkgstr-          ReplFailed      _ -> "repl failed for "    ++ pkgstr-          HaddocksFailed  _ -> "Failed to build documentation for " ++ pkgstr-          TestsFailed     _ -> "Tests failed for " ++ pkgstr-          BenchFailed     _ -> "Benchmarks failed for " ++ pkgstr-          InstallFailed   _ -> "Failed to build "  ++ pkgstr-          DependentFailed depid-                            -> "Failed to build " ++ prettyShow (packageId pkg)-                            ++ " because it depends on " ++ prettyShow depid-                            ++ " which itself failed to build"-      where-        pkgstr = elabConfiguredName verbosity pkg-              ++ if mentionDepOf-                   then renderDependencyOf (installedUnitId pkg)-                   else ""--    renderFailureExtraDetail (ConfigureFailed _) =-      " The failure occurred during the configure step."-    renderFailureExtraDetail (InstallFailed   _) =-      " The failure occurred during the final install step."-    renderFailureExtraDetail _                   =-      ""--    renderDependencyOf pkgid =-      case ultimateDeps pkgid of-        []         -> ""-        (p1:[])    ->-          " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"-        (p1:p2:[]) ->-          " (which is required by " ++ elabPlanPackageName verbosity p1-          ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")"-        (p1:p2:_)  ->-          " (which is required by " ++ elabPlanPackageName verbosity p1-          ++ ", " ++ elabPlanPackageName verbosity p2-          ++ " and others)"--    showException e = case fromException e of-      Just (ExitFailure 1) -> ""--#ifdef MIN_VERSION_unix-      -- Note [Positive "signal" exit code]-      -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-      -- What's the business with the test for negative and positive-      -- signal values?  The API for process specifies that if the-      -- process died due to a signal, it returns a *negative* exit-      -- code.  So that's the negative test.-      ---      -- What about the positive test?  Well, when we find out that-      -- a process died due to a signal, we ourselves exit with that-      -- exit code.  However, we don't "kill ourselves" with the-      -- signal; we just exit with the same code as the signal: thus-      -- the caller sees a *positive* exit code.  So that's what-      -- happens when we get a positive exit code.-      Just (ExitFailure n)-        | -n == fromIntegral sigSEGV ->-            " The build process segfaulted (i.e. SIGSEGV)."--        |  n == fromIntegral sigSEGV ->-            " The build process terminated with exit code " ++ show n-         ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."--        | -n == fromIntegral sigKILL ->-            " The build process was killed (i.e. SIGKILL). " ++ explanation--        |  n == fromIntegral sigKILL ->-            " The build process terminated with exit code " ++ show n-         ++ " which may be because some part of it was killed "-         ++ "(i.e. SIGKILL). " ++ explanation-        where-          explanation =-            "The typical reason for this is that there is not "-            ++ "enough memory available (e.g. the OS killed a process "-            ++ "using lots of memory)."-#endif-      Just (ExitFailure n) ->-        " The build process terminated with exit code " ++ show n--      _ -> " The exception was:\n  "-#if MIN_VERSION_base(4,8,0)-             ++ displayException e-#else-             ++ show e-#endif--    buildFailureException reason =-      case reason of-        DownloadFailed  e -> Just e-        UnpackFailed    e -> Just e-        ConfigureFailed e -> Just e-        BuildFailed     e -> Just e-        ReplFailed      e -> Just e-        HaddocksFailed  e -> Just e-        TestsFailed     e -> Just e-        BenchFailed     e -> Just e-        InstallFailed   e -> Just e-        DependentFailed _ -> Nothing--data BuildFailurePresentation =-       ShowBuildSummaryOnly   BuildFailureReason-     | ShowBuildSummaryAndLog BuildFailureReason FilePath------------------------------------------------------------------------------------ Dummy projects------------------------------------------------------------------------------------ | Create a dummy project context, without a .cabal or a .cabal.project file--- (a place where to put a temporary dist directory is still needed)-establishDummyProjectBaseContext-  :: Verbosity-  -> ProjectConfig-  -> DistDirLayout-     -- ^ Where to put the dist directory-  -> [PackageSpecifier UnresolvedSourcePackage]-     -- ^ The packages to be included in the project-  -> CurrentCommand-  -> IO ProjectBaseContext-establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do-    cabalDir <- getCabalDir--    globalConfig <- runRebuild ""-                  $ readGlobalConfig verbosity-                  $ projectConfigConfigFile-                  $ projectConfigShared cliConfig-    let projectConfig = globalConfig <> cliConfig--    let ProjectConfigBuildOnly {-          projectConfigLogsDir-        } = projectConfigBuildOnly projectConfig--        ProjectConfigShared {-          projectConfigStoreDir-        } = projectConfigShared projectConfig--        mlogsDir = flagToMaybe projectConfigLogsDir-        mstoreDir = flagToMaybe projectConfigStoreDir-        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir--        buildSettings = resolveBuildTimeSettings-                          verbosity cabalDirLayout-                          projectConfig--    return ProjectBaseContext {-      distDirLayout,-      cabalDirLayout,-      projectConfig,-      localPackages,-      buildSettings,-      currentCommand-    }--establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout-establishDummyDistDirLayout verbosity cliConfig tmpDir = do-    let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory--    -- Create the dist directories-    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout-    createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout--    return distDirLayout-  where-    mdistDirectory = flagToMaybe-                   $ projectConfigDistDir-                   $ projectConfigShared cliConfig-    projectRoot = ProjectRootImplicit tmpDir
− Distribution/Client/ProjectPlanOutput.hs 
@@ -1,939 +0,0 @@-{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,-             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,-             ScopedTypeVariables #-}--module Distribution.Client.ProjectPlanOutput (-    -- * Plan output-    writePlanExternalRepresentation,--    -- * Project status-    -- | Several outputs rely on having a general overview of-    PostBuildProjectStatus(..),-    updatePostBuildProjectStatus,-    createPackageEnvironment,-    writePlanGhcEnvironment,-    argsEquivalentOfGhcEnvironmentFile,-  ) where--import           Distribution.Client.ProjectPlanning.Types-import           Distribution.Client.ProjectBuilding.Types-import           Distribution.Client.DistDirLayout-import           Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..))-import           Distribution.Client.Types.PackageLocation (PackageLocation(..))-import           Distribution.Client.Types.ConfiguredId (confInstId)-import           Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))-import           Distribution.Client.HashValue (showHashValue, hashValue)-import           Distribution.Client.Utils (cabalInstallVersion)--import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.Utils.Json as J-import qualified Distribution.Simple.InstallDirs as InstallDirs--import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps--import           Distribution.Package-import           Distribution.System-import           Distribution.InstalledPackageInfo (InstalledPackageInfo)-import qualified Distribution.PackageDescription as PD-import           Distribution.Compiler (CompilerFlavor(GHC, GHCJS))-import           Distribution.Simple.Compiler-                   ( PackageDBStack, PackageDB(..)-                   , compilerVersion, compilerFlavor, showCompilerId-                   , compilerId, CompilerId(..), Compiler )-import           Distribution.Simple.GHC-                   ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)-                   , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile-                   , writeGhcEnvironmentFile )-import           Distribution.Simple.BuildPaths-                   ( dllExtension, exeExtension )-import qualified Distribution.Compat.Graph as Graph-import           Distribution.Compat.Graph (Graph, Node)-import qualified Distribution.Compat.Binary as Binary-import           Distribution.Simple.Utils-import           Distribution.Verbosity--import Prelude ()-import Distribution.Client.Compat.Prelude--import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Builder as BB--import           System.FilePath-import           System.IO--import Distribution.Simple.Program.GHC (packageDbArgsDb)---------------------------------------------------------------------------------- Writing plan.json files------- | Write out a representation of the elaborated install plan.------ This is for the benefit of debugging and external tools like editors.----writePlanExternalRepresentation :: DistDirLayout-                                -> ElaboratedInstallPlan-                                -> ElaboratedSharedConfig-                                -> IO ()-writePlanExternalRepresentation distDirLayout elaboratedInstallPlan-                                elaboratedSharedConfig =-    writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $-        BB.toLazyByteString-      . J.encodeToBuilder-      $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig---- | Renders a subset of the elaborated install plan in a semi-stable JSON--- format.----encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value-encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =-    --TODO: [nice to have] include all of the sharedPackageConfig and all of-    --      the parts of the elaboratedInstallPlan-    J.object [ "cabal-version"     J..= jdisplay cabalInstallVersion-             , "cabal-lib-version" J..= jdisplay cabalVersion-             , "compiler-id"       J..= (J.String . showCompilerId . pkgConfigCompiler)-                                        elaboratedSharedConfig-             , "os"                J..= jdisplay os-             , "arch"              J..= jdisplay arch-             , "install-plan"      J..= installPlanToJ elaboratedInstallPlan-             ]-  where-    plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig--    installPlanToJ :: ElaboratedInstallPlan -> [J.Value]-    installPlanToJ = map planPackageToJ . InstallPlan.toList--    planPackageToJ :: ElaboratedPlanPackage -> J.Value-    planPackageToJ pkg =-      case pkg of-        InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi-        InstallPlan.Configured elab -> elaboratedPackageToJ False elab-        InstallPlan.Installed  elab -> elaboratedPackageToJ True  elab-        -- Note that the plan.json currently only uses the elaborated plan,-        -- not the improved plan. So we will not get the Installed state for-        -- that case, but the code supports it in case we want to use this-        -- later in some use case where we want the status of the build.--    installedPackageInfoToJ :: InstalledPackageInfo -> J.Value-    installedPackageInfoToJ ipi =-      -- Pre-existing packages lack configuration information such as their flag-      -- settings or non-lib components. We only get pre-existing packages for-      -- the global/core packages however, so this isn't generally a problem.-      -- So these packages are never local to the project.-      ---      J.object-        [ "type"       J..= J.String "pre-existing"-        , "id"         J..= (jdisplay . installedUnitId) ipi-        , "pkg-name"   J..= (jdisplay . pkgName . packageId) ipi-        , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi-        , "depends"    J..= map jdisplay (installedDepends ipi)-        ]--    elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value-    elaboratedPackageToJ isInstalled elab =-      J.object $-        [ "type"       J..= J.String (if isInstalled then "installed"-                                                     else "configured")-        , "id"         J..= (jdisplay . installedUnitId) elab-        , "pkg-name"   J..= (jdisplay . pkgName . packageId) elab-        , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab-        , "flags"      J..= J.object [ PD.unFlagName fn J..= v-                                     | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ]-        , "style"      J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))-        , "pkg-src"    J..= packageLocationToJ (elabPkgSourceLocation elab)-        ] ++-        [ "pkg-cabal-sha256" J..= J.String (showHashValue hash)-        | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++-        [ "pkg-src-sha256" J..= J.String (showHashValue hash)-        | Just hash <- [elabPkgSourceHash elab] ] ++-        (case elabBuildStyle elab of-            BuildInplaceOnly ->-                ["dist-dir"   J..= J.String dist_dir]-            BuildAndInstall ->-                -- TODO: install dirs?-                []-            ) ++-        case elabPkgOrComp elab of-          ElabPackage pkg ->-            let components = J.object $-                  [ comp2str c J..= (J.object $-                    [ "depends"     J..= map (jdisplay . confInstId) ldeps-                    , "exe-depends" J..= map (jdisplay . confInstId) edeps-                    ] ++-                    bin_file c)-                  | (c,(ldeps,edeps))-                      <- ComponentDeps.toList $-                         ComponentDeps.zip (pkgLibDependencies pkg)-                                           (pkgExeDependencies pkg) ]-            in ["components" J..= components]-          ElabComponent comp ->-            ["depends"     J..= map (jdisplay . confInstId) (elabLibDependencies elab)-            ,"exe-depends" J..= map jdisplay (elabExeDependencies elab)-            ,"component-name" J..= J.String (comp2str (compSolverName comp))-            ] ++-            bin_file (compSolverName comp)-     where-      packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value-      packageLocationToJ pkgloc =-        case pkgloc of-          LocalUnpackedPackage local ->-            J.object [ "type" J..= J.String "local"-                     , "path" J..= J.String local-                     ]-          LocalTarballPackage local ->-            J.object [ "type" J..= J.String "local-tar"-                     , "path" J..= J.String local-                     ]-          RemoteTarballPackage uri _ ->-            J.object [ "type" J..= J.String "remote-tar"-                     , "uri"  J..= J.String (show uri)-                     ]-          RepoTarballPackage repo _ _ ->-            J.object [ "type" J..= J.String "repo-tar"-                     , "repo" J..= repoToJ repo-                     ]-          RemoteSourceRepoPackage srcRepo _ ->-            J.object [ "type" J..= J.String "source-repo"-                     , "source-repo" J..= sourceRepoToJ srcRepo-                     ]--      repoToJ :: Repo -> J.Value-      repoToJ repo =-        case repo of-          RepoLocalNoIndex{..} ->-            J.object [ "type" J..= J.String "local-repo-no-index"-                     , "path" J..= J.String repoLocalDir-                     ]-          RepoRemote{..} ->-            J.object [ "type" J..= J.String "remote-repo"-                     , "uri"  J..= J.String (show (remoteRepoURI repoRemote))-                     ]-          RepoSecure{..} ->-            J.object [ "type" J..= J.String "secure-repo"-                     , "uri"  J..= J.String (show (remoteRepoURI repoRemote))-                     ]--      sourceRepoToJ :: SourceRepoMaybe -> J.Value-      sourceRepoToJ SourceRepositoryPackage{..} =-        J.object $ filter ((/= J.Null) . snd) $-          [ "type"     J..= jdisplay srpType-          , "location" J..= J.String srpLocation-          , "branch"   J..= fmap J.String srpBranch-          , "tag"      J..= fmap J.String srpTag-          , "subdir"   J..= fmap J.String srpSubdir-          ]--      dist_dir = distBuildDirectory distDirLayout-                    (elabDistDirParams elaboratedSharedConfig elab)--      bin_file c = case c of-        ComponentDeps.ComponentExe s   -> bin_file' s-        ComponentDeps.ComponentTest s  -> bin_file' s-        ComponentDeps.ComponentBench s -> bin_file' s-        ComponentDeps.ComponentFLib s  -> flib_file' s-        _ -> []-      bin_file' s =-        ["bin-file" J..= J.String bin]-       where-        bin = if elabBuildStyle elab == BuildInplaceOnly-               then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat-               else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat--      flib_file' s =-        ["bin-file" J..= J.String bin]-       where-        bin = if elabBuildStyle elab == BuildInplaceOnly-               then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat-               else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat--    comp2str :: ComponentDeps.Component -> String-    comp2str = prettyShow--    style2str :: Bool -> BuildStyle -> String-    style2str True  _                = "local"-    style2str False BuildInplaceOnly = "inplace"-    style2str False BuildAndInstall  = "global"--    jdisplay :: Pretty a => a -> J.Value-    jdisplay = J.String . prettyShow----------------------------------------------------------------------------------- Project status------- So, what is the status of a project after a build? That is, how do the--- inputs (package source files etc) compare to the output artefacts (build--- libs, exes etc)? Do the outputs reflect the current values of the inputs--- or are outputs out of date or invalid?------ First of all, what do we mean by out-of-date and what do we mean by--- invalid? We think of the build system as a morally pure function that--- computes the output artefacts given input values. We say an output artefact--- is out of date when its value is not the value that would be computed by a--- build given the current values of the inputs. An output artefact can be--- out-of-date but still be perfectly usable; it simply correspond to a--- previous state of the inputs.------ On the other hand there are cases where output artefacts cannot safely be--- used. For example libraries and dynamically linked executables cannot be--- used when the libs they depend on change without them being recompiled--- themselves. Whether an artefact is still usable depends on what it is, e.g.--- dynamically linked vs statically linked and on how it gets updated (e.g.--- only atomically on success or if failure can leave invalid states). We need--- a definition (or two) that is independent of the kind of artefact and can--- be computed just in terms of changes in package graphs, but are still--- useful for determining when particular kinds of artefacts are invalid.------ Note that when we talk about packages in this context we just mean nodes--- in the elaborated install plan, which can be components or packages.------ There's obviously a close connection between packages being out of date and--- their output artefacts being unusable: most of the time if a package--- remains out of date at the end of a build then some of its output artefacts--- will be unusable. That is true most of the time because a build will have--- attempted to build one of the out-of-date package's dependencies. If the--- build of the dependency succeeded then it changed output artefacts (like--- libs) and if it failed then it may have failed after already changing--- things (think failure after updating some but not all .hi files).------ There are a few reasons we may end up with still-usable output artefacts--- for a package even when it remains out of date at the end of a build.--- Firstly if executing a plan fails then packages can be skipped, and thus we--- may have packages where all their dependencies were skipped. Secondly we--- have artefacts like statically linked executables which are not affected by--- libs they depend on being recompiled. Furthermore, packages can be out of--- date due to changes in build tools or Setup.hs scripts they depend on, but--- again libraries or executables in those out-of-date packages remain usable.------ So we have two useful definitions of invalid. Both are useful, for--- different purposes, so we will compute both. The first corresponds to the--- invalid libraries and dynamic executables. We say a package is invalid by--- changed deps if any of the packages it depends on (via library dep edges)--- were rebuilt (successfully or unsuccessfully). The second definition--- corresponds to invalid static executables. We say a package is invalid by--- a failed build simply if the package was built but unsuccessfully.------ So how do we find out what packages are out of date or invalid?------ Obviously we know something for all the packages that were part of the plan--- that was executed, but that is just a subset since we prune the plan down--- to the targets and their dependencies.------ Recall the steps we go though:------ + starting with the initial improved plan (this is the full project);------ + prune the plan to the user's build targets;------ + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap---   covering the pruned subset of the original plan;------ + execute the plan giving us BuildOutcomes which tell us success/failure---   for each package.------ So given that the BuildStatusMap and BuildOutcomes do not cover everything--- in the original plan, what can they tell us about the original plan?------ The BuildStatusMap tells us directly that some packages are up to date and--- others out of date (but only for the pruned subset). But we know that--- everything that is a reverse dependency of an out-of-date package is itself--- out-of-date (whether or not it is in the pruned subset). Of course after--- a build the BuildOutcomes may tell us that some of those out-of-date--- packages are now up to date (ie a successful build outcome).------ The difference is packages that are reverse dependencies of out-of-date--- packages but are not brought up-to-date by the build (i.e. did not have--- successful outcomes, either because they failed or were not in the pruned--- subset to be built). We also know which packages were rebuilt, so we can--- use this to find the now-invalid packages.------ Note that there are still packages for which we cannot discover full status--- information. There may be packages outside of the pruned plan that do not--- depend on packages within the pruned plan that were discovered to be--- out-of-date. For these packages we do not know if their build artefacts--- are out-of-date or not. We do know however that they are not invalid, as--- that's not possible given our definition of invalid. Intuitively it is--- because we have not disturbed anything that these packages depend on, e.g.--- we've not rebuilt any libs they depend on. Recall that our widest--- definition of invalid was only concerned about dependencies on libraries--- (to cover problems like shared libs or GHC seeing inconsistent .hi files).------ So our algorithm for out-of-date packages is relatively simple: take the--- reverse dependency closure in the original improved plan (pre-pruning) of--- the out-of-date packages (as determined by the BuildStatusMap from the dry--- run). That gives a set of packages that were definitely out of date after--- the dry run. Now we remove from this set the packages that the--- BuildOutcomes tells us are now up-to-date after the build. The remaining--- set is the out-of-date packages.------ As for packages that are invalid by changed deps, we start with the plan--- dependency graph but keep only those edges that point to libraries (so--- ignoring deps on exes and setup scripts). We take the packages for which a--- build was attempted (successfully or unsuccessfully, but not counting--- knock-on failures) and take the reverse dependency closure. We delete from--- this set all the packages that were built successfully. Note that we do not--- need to intersect with the out-of-date packages since this follows--- automatically: all rev deps of packages we attempted to build must have--- been out of date at the start of the build, and if they were not built--- successfully then they're still out of date -- meeting our definition of--- invalid.---type PackageIdSet     = Set UnitId-type PackagesUpToDate = PackageIdSet--data PostBuildProjectStatus = PostBuildProjectStatus {--       -- | Packages that are known to be up to date. These were found to be-       -- up to date before the build, or they have a successful build outcome-       -- afterwards.-       ---       -- This does not include any packages outside of the subset of the plan-       -- that was executed because we did not check those and so don't know-       -- for sure that they're still up to date.-       ---       packagesDefinitelyUpToDate :: PackageIdSet,--       -- | Packages that are probably still up to date (and at least not-       -- known to be out of date, and certainly not invalid). This includes-       -- 'packagesDefinitelyUpToDate' plus packages that were up to date-       -- previously and are outside of the subset of the plan that was-       -- executed. It excludes 'packagesOutOfDate'.-       ---       packagesProbablyUpToDate :: PackageIdSet,--       -- | Packages that are known to be out of date. These are packages-       -- that were determined to be out of date before the build, and they-       -- do not have a successful build outcome afterwards.-       ---       -- Note that this can sometimes include packages outside of the subset-       -- of the plan that was executed. For example suppose package A and B-       -- depend on C, and A is the target so only A and C are in the subset-       -- to be built. Now suppose C is found to have changed, then both A-       -- and B are out-of-date before the build and since B is outside the-       -- subset to be built then it will remain out of date.-       ---       -- Note also that this is /not/ the inverse of-       -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'.-       -- There are packages where we have no information (ones that were not-       -- in the subset of the plan that was executed).-       ---       packagesOutOfDate :: PackageIdSet,--       -- | Packages that depend on libraries that have changed during the-       -- build (either build success or failure).-       ---       -- This corresponds to the fact that libraries and dynamic executables-       -- are invalid once any of the libs they depend on change.-       ---       -- This does include packages that themselves failed (i.e. it is a-       -- superset of 'packagesInvalidByFailedBuild'). It does not include-       -- changes in dependencies on executables (i.e. build tools).-       ---       packagesInvalidByChangedLibDeps :: PackageIdSet,--       -- | Packages that themselves failed during the build (i.e. them-       -- directly not a dep).-       ---       -- This corresponds to the fact that static executables are invalid-       -- in unlucky circumstances such as linking failing half way though,-       -- or data file generation failing.-       ---       -- This is a subset of 'packagesInvalidByChangedLibDeps'.-       ---       packagesInvalidByFailedBuild :: PackageIdSet,--       -- | A subset of the plan graph, including only dependency-on-library-       -- edges. That is, dependencies /on/ libraries, not dependencies /of/-       -- libraries. This tells us all the libraries that packages link to.-       ---       -- This is here as a convenience, as strictly speaking it's not status-       -- as it's just a function of the original 'ElaboratedInstallPlan'.-       ---       packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage),--       -- | As a convenience for 'Set.intersection' with any of the other-       -- 'PackageIdSet's to select only packages that are part of the-       -- project locally (i.e. with a local source dir).-       ---       packagesBuildLocal     :: PackageIdSet,--       -- | As a convenience for 'Set.intersection' with any of the other-       -- 'PackageIdSet's to select only packages that are being built-       -- in-place within the project (i.e. not destined for the store).-       ---       packagesBuildInplace   :: PackageIdSet,--       -- | As a convenience for 'Set.intersection' or 'Set.difference' with-       -- any of the other 'PackageIdSet's to select only packages that were-       -- pre-installed or already in the store prior to the build.-       ---       packagesAlreadyInStore :: PackageIdSet-     }---- | Work out which packages are out of date or invalid after a build.----postBuildProjectStatus :: ElaboratedInstallPlan-                       -> PackagesUpToDate-                       -> BuildStatusMap-                       -> BuildOutcomes-                       -> PostBuildProjectStatus-postBuildProjectStatus plan previousPackagesUpToDate-                       pkgBuildStatus buildOutcomes =-    PostBuildProjectStatus {-      packagesDefinitelyUpToDate,-      packagesProbablyUpToDate,-      packagesOutOfDate,-      packagesInvalidByChangedLibDeps,-      packagesInvalidByFailedBuild,-      -- convenience stuff-      packagesLibDepGraph,-      packagesBuildLocal,-      packagesBuildInplace,-      packagesAlreadyInStore-    }-  where-    packagesDefinitelyUpToDate =-       packagesUpToDatePreBuild-        `Set.union`-       packagesSuccessfulPostBuild--    packagesProbablyUpToDate =-      packagesDefinitelyUpToDate-        `Set.union`-      (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild)--    packagesOutOfDate =-      packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild--    packagesInvalidByChangedLibDeps =-      packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild--    packagesInvalidByFailedBuild =-      packagesFailurePostBuild--    -- Note: if any of the intermediate values below turn out to be useful in-    -- their own right then we can simply promote them to the result record--    -- The previous set of up-to-date packages will contain bogus package ids-    -- when the solver plan or config contributing to the hash changes.-    -- So keep only the ones where the package id (i.e. hash) is the same.-    previousPackagesUpToDate' =-      Set.intersection-        previousPackagesUpToDate-        (InstallPlan.keysSet plan)--    packagesUpToDatePreBuild =-      Set.filter-        (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid))-        -- For packages not in the plan subset we did the dry-run on we don't-        -- know anything about their status, so not known to be /up to date/.-        (InstallPlan.keysSet plan)--    packagesOutOfDatePreBuild =-      Set.fromList . map installedUnitId $-      InstallPlan.reverseDependencyClosure plan-        [ ipkgid-        | pkg <- InstallPlan.toList plan-        , let ipkgid = installedUnitId pkg-        , lookupBuildStatusRequiresBuild False ipkgid-        -- For packages not in the plan subset we did the dry-run on we don't-        -- know anything about their status, so not known to be /out of date/.-        ]--    packagesSuccessfulPostBuild =-      Set.fromList-        [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ]--    -- direct failures, not failures due to deps-    packagesFailurePostBuild =-      Set.fromList-        [ ikgid-        | (ikgid, Left failure) <- Map.toList buildOutcomes-        , case buildFailureReason failure of-            DependentFailed _ -> False-            _                 -> True-        ]--    -- Packages that have a library dependency on a package for which a build-    -- was attempted-    packagesDepOnChangedLib =-      Set.fromList . map Graph.nodeKey $-      fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $-      Graph.revClosure packagesLibDepGraph-        ( Map.keys-        . Map.filter (uncurry buildAttempted)-        $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes-        )--    -- The plan graph but only counting dependency-on-library edges-    packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)-    packagesLibDepGraph =-      Graph.fromDistinctList-        [ Graph.N pkg (installedUnitId pkg) libdeps-        | pkg <- InstallPlan.toList plan-        , let libdeps = case pkg of-                InstallPlan.PreExisting ipkg  -> installedDepends ipkg-                InstallPlan.Configured srcpkg -> elabLibDeps srcpkg-                InstallPlan.Installed  srcpkg -> elabLibDeps srcpkg-        ]-    elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies--    -- Was a build was attempted for this package?-    -- If it doesn't have both a build status and outcome then the answer is no.-    buildAttempted :: BuildStatus -> BuildOutcome -> Bool-    -- And not if it didn't need rebuilding in the first place.-    buildAttempted buildStatus _buildOutcome-      | not (buildStatusRequiresBuild buildStatus)-      = False--    -- And not if it was skipped due to a dep failing first.-    buildAttempted _ (Left BuildFailure {buildFailureReason})-      | DependentFailed _ <- buildFailureReason-      = False--    -- Otherwise, succeeded or failed, yes the build was tried.-    buildAttempted _ (Left BuildFailure {}) = True-    buildAttempted _ (Right _)              = True--    lookupBuildStatusRequiresBuild def ipkgid =-      case Map.lookup ipkgid pkgBuildStatus of-        Nothing          -> def -- Not in the plan subset we did the dry-run on-        Just buildStatus -> buildStatusRequiresBuild buildStatus--    packagesBuildLocal =-      selectPlanPackageIdSet $ \pkg ->-        case pkg of-          InstallPlan.PreExisting _     -> False-          InstallPlan.Installed   _     -> False-          InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg--    packagesBuildInplace =-      selectPlanPackageIdSet $ \pkg ->-        case pkg of-          InstallPlan.PreExisting _     -> False-          InstallPlan.Installed   _     -> False-          InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg-                                        == BuildInplaceOnly--    packagesAlreadyInStore =-      selectPlanPackageIdSet $ \pkg ->-        case pkg of-          InstallPlan.PreExisting _ -> True-          InstallPlan.Installed   _ -> True-          InstallPlan.Configured  _ -> False--    selectPlanPackageIdSet p = Map.keysSet-                             . Map.filter p-                             $ InstallPlan.toMap plan----updatePostBuildProjectStatus :: Verbosity-                             -> DistDirLayout-                             -> ElaboratedInstallPlan-                             -> BuildStatusMap-                             -> BuildOutcomes-                             -> IO PostBuildProjectStatus-updatePostBuildProjectStatus verbosity distDirLayout-                             elaboratedInstallPlan-                             pkgsBuildStatus buildOutcomes = do--    -- Read the previous up-to-date set, update it and write it back-    previousUpToDate   <- readPackagesUpToDateCacheFile distDirLayout-    let currentBuildStatus@PostBuildProjectStatus{..}-                        = postBuildProjectStatus-                            elaboratedInstallPlan-                            previousUpToDate-                            pkgsBuildStatus-                            buildOutcomes-    let currentUpToDate = packagesProbablyUpToDate-    writePackagesUpToDateCacheFile distDirLayout currentUpToDate--    -- Report various possibly interesting things-    -- We additionally intersect with the packagesBuildInplace so that-    -- we don't show huge numbers of boring packages from the store.-    debugNoWrap verbosity $-        "packages definitely up to date: "-     ++ displayPackageIdSet (packagesDefinitelyUpToDate-          `Set.intersection` packagesBuildInplace)--    debugNoWrap verbosity $-        "packages previously probably up to date: "-     ++ displayPackageIdSet (previousUpToDate-          `Set.intersection` packagesBuildInplace)--    debugNoWrap verbosity $-        "packages now probably up to date: "-     ++ displayPackageIdSet (packagesProbablyUpToDate-          `Set.intersection` packagesBuildInplace)--    debugNoWrap verbosity $-        "packages newly up to date: "-     ++ displayPackageIdSet (packagesDefinitelyUpToDate-            `Set.difference` previousUpToDate-          `Set.intersection` packagesBuildInplace)--    debugNoWrap verbosity $-        "packages out to date: "-     ++ displayPackageIdSet (packagesOutOfDate-          `Set.intersection` packagesBuildInplace)--    debugNoWrap verbosity $-        "packages invalid due to dep change: "-     ++ displayPackageIdSet packagesInvalidByChangedLibDeps--    debugNoWrap verbosity $-        "packages invalid due to build failure: "-     ++ displayPackageIdSet packagesInvalidByFailedBuild--    return currentBuildStatus-  where-    displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList---- | Helper for reading the cache file.------ This determines the type and format of the binary cache file.----readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate-readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =-    handleDoesNotExist Set.empty $-    handleDecodeFailure $-      withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd ->-        Binary.decodeOrFailIO =<< BS.hGetContents hnd-  where-    handleDecodeFailure = fmap (either (const Set.empty) id)---- | Helper for writing the package up-to-date cache file.------ This determines the type and format of the binary cache file.----writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()-writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =-    writeFileAtomic (distProjectCacheFile "up-to-date") $-      Binary.encode upToDate---- | Prepare a package environment that includes all the library dependencies--- for a plan.------ When running cabal new-exec, we want to set things up so that the compiler--- can find all the right packages (and nothing else). This function is--- intended to do that work. It takes a location where it can write files--- temporarily, in case the compiler wants to learn this information via the--- filesystem, and returns any environment variable overrides the compiler--- needs.-createPackageEnvironment :: Verbosity-                         -> FilePath-                         -> ElaboratedInstallPlan-                         -> ElaboratedSharedConfig-                         -> PostBuildProjectStatus-                         -> IO [(String, Maybe String)]-createPackageEnvironment verbosity-                         path-                         elaboratedPlan-                         elaboratedShared-                         buildStatus-  | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC-  = do-    envFileM <- writePlanGhcEnvironment-      path-      elaboratedPlan-      elaboratedShared-      buildStatus-    case envFileM of-      Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)]-      Nothing -> do-        warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail"-        return []-  | otherwise-  = do-    warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"-    return []---- Writing .ghc.environment files-----writePlanGhcEnvironment :: FilePath-                        -> ElaboratedInstallPlan-                        -> ElaboratedSharedConfig-                        -> PostBuildProjectStatus-                        -> IO (Maybe FilePath)-writePlanGhcEnvironment path-                        elaboratedInstallPlan-                        ElaboratedSharedConfig {-                          pkgConfigCompiler = compiler,-                          pkgConfigPlatform = platform-                        }-                        postBuildStatus-  | compilerFlavor compiler == GHC-  , supportsPkgEnvFiles (getImplInfo compiler)-  --TODO: check ghcjs compat-  = fmap Just $ writeGhcEnvironmentFile-      path-      platform (compilerVersion compiler)-      (renderGhcEnvironmentFile path-                                elaboratedInstallPlan-                                postBuildStatus)-    --TODO: [required eventually] support for writing user-wide package-    -- environments, e.g. like a global project, but we would not put the-    -- env file in the home dir, rather it lives under ~/.ghc/--writePlanGhcEnvironment _ _ _ _ = return Nothing--renderGhcEnvironmentFile :: FilePath-                         -> ElaboratedInstallPlan-                         -> PostBuildProjectStatus-                         -> [GhcEnvironmentFileEntry]-renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan-                         postBuildStatus =-    headerComment-  : simpleGhcEnvironmentFile packageDBs unitIds-  where-    headerComment =-        GhcEnvFileComment-      $ "This is a GHC environment file written by cabal. This means you can\n"-     ++ "run ghc or ghci and get the environment of the project as a whole.\n"-     ++ "But you still need to use cabal repl $target to get the environment\n"-     ++ "of specific components (libs, exes, tests etc) because each one can\n"-     ++ "have its own source dirs, cpp flags etc.\n\n"-    unitIds    = selectGhcEnvironmentFileLibraries postBuildStatus-    packageDBs = relativePackageDBPaths projectRootDir $-                 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan---argsEquivalentOfGhcEnvironmentFile-  :: Compiler-  -> DistDirLayout-  -> ElaboratedInstallPlan-  -> PostBuildProjectStatus-  -> [String]-argsEquivalentOfGhcEnvironmentFile compiler =-  case compilerId compiler-  of CompilerId GHC   _ -> argsEquivalentOfGhcEnvironmentFileGhc-     CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc-     CompilerId _     _ -> error "Only GHC and GHCJS are supported"---- TODO remove this when we drop support for non-.ghc.env ghc-argsEquivalentOfGhcEnvironmentFileGhc-  :: DistDirLayout-  -> ElaboratedInstallPlan-  -> PostBuildProjectStatus-  -> [String]-argsEquivalentOfGhcEnvironmentFileGhc-  distDirLayout-  elaboratedInstallPlan-  postBuildStatus =-    clearPackageDbStackFlag- ++ packageDbArgsDb packageDBs- ++ foldMap packageIdFlag packageIds-  where-    projectRootDir = distProjectRootDirectory distDirLayout-    packageIds = selectGhcEnvironmentFileLibraries postBuildStatus-    packageDBs = relativePackageDBPaths projectRootDir $-                 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan-    -- TODO use proper flags? but packageDbArgsDb is private-    clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]-    packageIdFlag uid = ["-package-id", prettyShow uid]----- We're producing an environment for users to use in ghci, so of course--- that means libraries only (can't put exes into the ghc package env!).--- The library environment should be /consistent/ with the environment--- that each of the packages in the project use (ie same lib versions).--- So that means all the normal library dependencies of all the things--- in the project (including deps of exes that are local to the project).--- We do not however want to include the dependencies of Setup.hs scripts,--- since these are generally uninteresting but also they need not in--- general be consistent with the library versions that packages local to--- the project use (recall that Setup.hs script's deps can be picked--- independently of other packages in the project).------ So, our strategy is as follows:------ produce a dependency graph of all the packages in the install plan,--- but only consider normal library deps as edges in the graph. Thus we--- exclude the dependencies on Setup.hs scripts (in the case of--- per-component granularity) or of Setup.hs scripts (in the case of--- per-package granularity). Then take a dependency closure, using as--- roots all the packages/components local to the project. This will--- exclude Setup scripts and their dependencies.------ Note: this algorithm will have to be adapted if/when the install plan--- is extended to cover multiple compilers at once, and may also have to--- change if we start to treat unshared deps of test suites in a similar--- way to how we treat Setup.hs script deps (ie being able to pick them--- independently).------ Since we had to use all the local packages, including exes, (as roots--- to find the libs) then those exes still end up in our list so we have--- to filter them out at the end.----selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]-selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =-    case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of-      Nothing    -> error "renderGhcEnvironmentFile: broken dep closure"-      Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes-                            , hasUpToDateLib pkg ]-  where-    hasUpToDateLib planpkg = case planpkg of-      -- A pre-existing global lib-      InstallPlan.PreExisting  _ -> True--      -- A package in the store. Check it's a lib.-      InstallPlan.Installed  pkg -> elabRequiresRegistration pkg--      -- A package we were installing this time, either destined for the store-      -- or just locally. Check it's a lib and that it is probably up to date.-      InstallPlan.Configured pkg ->-          elabRequiresRegistration pkg-       && installedUnitId pkg `Set.member` packagesProbablyUpToDate---selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack-selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =-    -- If we have any inplace packages then their package db stack is the-    -- one we should use since it'll include the store + the local db but-    -- it's certainly possible to have no local inplace packages-    -- e.g. just "extra" packages coming from the store.-    case (inplacePackages, sourcePackages) of-      ([], pkgs) -> checkSamePackageDBs pkgs-      (pkgs, _)  -> checkSamePackageDBs pkgs-  where-    checkSamePackageDBs pkgs =-      case ordNub (map elabBuildPackageDBStack pkgs) of-        [packageDbs] -> packageDbs-        []           -> []-        _            -> error $ "renderGhcEnvironmentFile: packages with "-                             ++ "different package db stacks"-        -- This should not happen at the moment but will happen as soon-        -- as we support projects where we build packages with different-        -- compilers, at which point we have to consider how to adapt-        -- this feature, e.g. write out multiple env files, one for each-        -- compiler / project profile.--    inplacePackages =-      [ srcpkg-      | srcpkg <- sourcePackages-      , elabBuildStyle srcpkg == BuildInplaceOnly ]-    sourcePackages =-      [ srcpkg-      | pkg <- InstallPlan.toList elaboratedInstallPlan-      , srcpkg <- maybeToList $ case pkg of-                    InstallPlan.Configured srcpkg -> Just srcpkg-                    InstallPlan.Installed  srcpkg -> Just srcpkg-                    InstallPlan.PreExisting _     -> Nothing-      ]--relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack-relativePackageDBPaths relroot = map (relativePackageDBPath relroot)--relativePackageDBPath :: FilePath -> PackageDB -> PackageDB-relativePackageDBPath relroot pkgdb =-    case pkgdb of-      GlobalPackageDB        -> GlobalPackageDB-      UserPackageDB          -> UserPackageDB-      SpecificPackageDB path -> SpecificPackageDB relpath-        where relpath = makeRelative relroot path
− Distribution/Client/ProjectPlanning.hs 
@@ -1,3800 +0,0 @@-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoMonoLocalBinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}---- | Planning how to build everything in a project.----module Distribution.Client.ProjectPlanning (-    -- * elaborated install plan types-    ElaboratedInstallPlan,-    ElaboratedConfiguredPackage(..),-    ElaboratedPlanPackage,-    ElaboratedSharedConfig(..),-    ElaboratedReadyPackage,-    BuildStyle(..),-    CabalFileText,--    -- * Producing the elaborated install plan-    rebuildProjectConfig,-    rebuildInstallPlan,--    -- * Build targets-    availableTargets,-    AvailableTarget(..),-    AvailableTargetStatus(..),-    TargetRequested(..),-    ComponentTarget(..),-    SubComponentTarget(..),-    showComponentTarget,-    nubComponentTargets,--    -- * Selecting a plan subset-    pruneInstallPlanToTargets,-    TargetAction(..),-    pruneInstallPlanToDependencies,-    CannotPruneDependencies(..),--    -- * Utils required for building-    pkgHasEphemeralBuildTargets,-    elabBuildTargetWholeComponents,--    -- * Setup.hs CLI flags for building-    setupHsScriptOptions,-    setupHsConfigureFlags,-    setupHsConfigureArgs,-    setupHsBuildFlags,-    setupHsBuildArgs,-    setupHsReplFlags,-    setupHsReplArgs,-    setupHsTestFlags,-    setupHsTestArgs,-    setupHsBenchFlags,-    setupHsBenchArgs,-    setupHsCopyFlags,-    setupHsRegisterFlags,-    setupHsHaddockFlags,-    setupHsHaddockArgs,--    packageHashInputs,--    -- * Path construction-    binDirectoryFor,-    binDirectories,-    storePackageInstallDirs,-    storePackageInstallDirs'-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import           Distribution.Client.HashValue-import           Distribution.Client.ProjectPlanning.Types as Ty-import           Distribution.Client.PackageHash-import           Distribution.Client.RebuildMonad-import           Distribution.Client.Store-import           Distribution.Client.ProjectConfig-import           Distribution.Client.ProjectPlanOutput--import           Distribution.Client.Types-import qualified Distribution.Client.InstallPlan as InstallPlan-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan-import           Distribution.Client.Dependency-import           Distribution.Client.Dependency.Types-import qualified Distribution.Client.IndexUtils as IndexUtils-import           Distribution.Client.Init (incVersion)-import           Distribution.Client.Targets (userToPackageConstraint)-import           Distribution.Client.DistDirLayout-import           Distribution.Client.SetupWrapper-import           Distribution.Client.JobControl-import           Distribution.Client.FetchUtils-import           Distribution.Client.Config-import qualified Hackage.Security.Client as Sec-import           Distribution.Client.Setup hiding (packageName, cabalVersion)-import           Distribution.Utils.NubList-import           Distribution.Utils.LogProgress-import           Distribution.Utils.MapAccum--import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import           Distribution.Solver.Types.ConstraintSource-import           Distribution.Solver.Types.LabeledPackageConstraint-import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Solver.Types.PkgConfigDb-import           Distribution.Solver.Types.ResolverPackage-import           Distribution.Solver.Types.SolverId-import           Distribution.Solver.Types.SolverPackage-import           Distribution.Solver.Types.InstSolverPackage-import           Distribution.Solver.Types.SourcePackage-import           Distribution.Solver.Types.Settings--import           Distribution.CabalSpecVersion-import           Distribution.ModuleName-import           Distribution.Package-import           Distribution.Types.AnnotatedId-import           Distribution.Types.ComponentName-import           Distribution.Types.LibraryName-import           Distribution.Types.GivenComponent-  (GivenComponent(..))-import           Distribution.Types.PackageVersionConstraint-import           Distribution.Types.PkgconfigDependency-import           Distribution.Types.UnqualComponentName-import           Distribution.System-import qualified Distribution.PackageDescription as Cabal-import qualified Distribution.PackageDescription as PD-import qualified Distribution.PackageDescription.Configuration as PD-import           Distribution.Simple.PackageIndex (InstalledPackageIndex)-import           Distribution.Simple.Compiler-import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate-import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate-import           Distribution.Simple.Program-import           Distribution.Simple.Program.Db-import           Distribution.Simple.Program.Find-import qualified Distribution.Simple.Setup as Cabal-import           Distribution.Simple.Setup-  (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault)-import qualified Distribution.Simple.Configure as Cabal-import qualified Distribution.Simple.LocalBuildInfo as Cabal-import           Distribution.Simple.LocalBuildInfo-                   ( Component(..), pkgComponents, componentBuildInfo-                   , componentName )-import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.InstalledPackageInfo as IPI--import           Distribution.Backpack.ConfiguredComponent-import           Distribution.Backpack.LinkedComponent-import           Distribution.Backpack.ComponentsGraph-import           Distribution.Backpack.ModuleShape-import           Distribution.Backpack.FullUnitId-import           Distribution.Backpack-import           Distribution.Types.ComponentInclude--import           Distribution.Simple.Utils-import           Distribution.Version--import qualified Distribution.Compat.Graph as Graph-import           Distribution.Compat.Graph(IsNode(..))--import           Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma)-import qualified Text.PrettyPrint as Disp-import qualified Data.Map as Map-import qualified Data.Set as Set-import           Control.Monad.State as State-import           Control.Exception (assert)-import           Data.List (groupBy)-import qualified Data.List.NonEmpty as NE-import           System.FilePath----------------------------------------------------------------------------------- * Elaborated install plan----------------------------------------------------------------------------------- "Elaborated" -- worked out with great care and nicety of detail;---                 executed with great minuteness: elaborate preparations;---                 elaborate care.------ So here's the idea:------ Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc--- all passed in as separate args and which are then further selected,--- transformed etc during the execution of the build. Instead we construct--- an elaborated install plan that includes everything we will need, and then--- during the execution of the plan we do as little transformation of this--- info as possible.------ So we're trying to split the work into two phases: construction of the--- elaborated install plan (which as far as possible should be pure) and--- then simple execution of that plan without any smarts, just doing what the--- plan says to do.------ So that means we need a representation of this fully elaborated install--- plan. The representation consists of two parts:------ * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a---   representation of source packages that includes a lot more detail about---   that package's individual configuration------ * A 'ElaboratedSharedConfig'. Some package configuration is the same for---   every package in a plan. Rather than duplicate that info every entry in---   the 'GenericInstallPlan' we keep that separately.------ The division between the shared and per-package config is /not set in stone--- for all time/. For example if we wanted to generalise the install plan to--- describe a situation where we want to build some packages with GHC and some--- with GHCJS then the platform and compiler would no longer be shared between--- all packages but would have to be per-package (probably with some sanity--- condition on the graph structure).------- Refer to ProjectPlanning.Types for details of these important types:---- type ElaboratedInstallPlan = ...--- type ElaboratedPlanPackage = ...--- data ElaboratedSharedConfig = ...--- data ElaboratedConfiguredPackage = ...--- data BuildStyle =----- | Check that an 'ElaboratedConfiguredPackage' actually makes--- sense under some 'ElaboratedSharedConfig'.-sanityCheckElaboratedConfiguredPackage-    :: ElaboratedSharedConfig-    -> ElaboratedConfiguredPackage-    -> a-    -> a-sanityCheckElaboratedConfiguredPackage sharedConfig-                             elab@ElaboratedConfiguredPackage{..} =-    (case elabPkgOrComp of-        ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg-        ElabComponent comp -> sanityCheckElaboratedComponent elab comp)--    -- either a package is being built inplace, or the-    -- 'installedPackageId' we assigned is consistent with-    -- the 'hashedInstalledPackageId' we would compute from-    -- the elaborated configured package-  . assert (elabBuildStyle == BuildInplaceOnly ||-     elabComponentId == hashedInstalledPackageId-                            (packageHashInputs sharedConfig elab))--    -- the stanzas explicitly disabled should not be available-  . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested)-                `Set.intersection` elabStanzasAvailable))--    -- either a package is built inplace, or we are not attempting to-    -- build any test suites or benchmarks (we never build these-    -- for remote packages!)-  . assert (elabBuildStyle == BuildInplaceOnly ||-     Set.null elabStanzasAvailable)--sanityCheckElaboratedComponent-    :: ElaboratedConfiguredPackage-    -> ElaboratedComponent-    -> a-    -> a-sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..}-                               ElaboratedComponent{..} =--    -- Should not be building bench or test if not inplace.-    assert (elabBuildStyle == BuildInplaceOnly ||-     case compComponentName of-        Nothing              -> True-        Just (CLibName _)    -> True-        Just (CExeName _)    -> True-        -- This is interesting: there's no way to declare a dependency-        -- on a foreign library at the moment, but you may still want-        -- to install these to the store-        Just (CFLibName _)   -> True-        Just (CBenchName _)  -> False-        Just (CTestName _)   -> False)---sanityCheckElaboratedPackage-    :: ElaboratedConfiguredPackage-    -> ElaboratedPackage-    -> a-    -> a-sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..}-                             ElaboratedPackage{..} =-    -- we should only have enabled stanzas that actually can be built-    -- (according to the solver)-    assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable)--    -- the stanzas that the user explicitly requested should be-    -- enabled (by the previous test, they are also available)-  . assert (Map.keysSet (Map.filter id elabStanzasRequested)-                `Set.isSubsetOf` pkgStanzasEnabled)----------------------------------------------------------------------------------- * Deciding what to do: making an 'ElaboratedInstallPlan'----------------------------------------------------------------------------------- | Return the up-to-date project config and information about the local--- packages within the project.----rebuildProjectConfig :: Verbosity-                     -> DistDirLayout-                     -> ProjectConfig-                     -> IO ( ProjectConfig-                           , [PackageSpecifier UnresolvedSourcePackage] )-rebuildProjectConfig verbosity-                     distDirLayout@DistDirLayout {-                       distProjectRootDirectory,-                       distDirectory,-                       distProjectCacheFile,-                       distProjectCacheDirectory,-                       distProjectFile-                     }-                     cliConfig = do--    fileMonitorProjectConfigKey <- do-      configPath <- getConfigFilePath projectConfigConfigFile-      return (configPath, distProjectFile "")--    (projectConfig, localPackages) <--      runRebuild distProjectRootDirectory-      $ rerunIfChanged verbosity-                       fileMonitorProjectConfig-                       fileMonitorProjectConfigKey-      $ do-          liftIO $ info verbosity "Project settings changed, reconfiguring..."-          projectConfig <- phaseReadProjectConfig-          localPackages <- phaseReadLocalPackages projectConfig-          return (projectConfig, localPackages)--    info verbosity-      $ unlines-      $ ("this build was affected by the following (project) config files:" :)-      $ [ "- " ++ path-        | Explicit path <- Set.toList $ projectConfigProvenance projectConfig-        ]--    return (projectConfig <> cliConfig, localPackages)--  where--    ProjectConfigShared { projectConfigConfigFile } =-      projectConfigShared cliConfig--    fileMonitorProjectConfig =-      newFileMonitor (distProjectCacheFile "config") :: FileMonitor-          (FilePath, FilePath)-          (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])--    -- Read the cabal.project (or implicit config) and combine it with-    -- arguments from the command line-    ---    phaseReadProjectConfig :: Rebuild ProjectConfig-    phaseReadProjectConfig = do-      readProjectConfig verbosity projectConfigConfigFile distDirLayout--    -- Look for all the cabal packages in the project-    -- some of which may be local src dirs, tarballs etc-    ---    phaseReadLocalPackages :: ProjectConfig-                           -> Rebuild [PackageSpecifier UnresolvedSourcePackage]-    phaseReadLocalPackages projectConfig@ProjectConfig {-                               projectConfigShared,-                               projectConfigBuildOnly-                             } = do-      pkgLocations <- findProjectPackages distDirLayout projectConfig--      -- Create folder only if findProjectPackages did not throw a-      -- BadPackageLocations exception.-      liftIO $ do-        createDirectoryIfMissingVerbose verbosity True distDirectory-        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory--      fetchAndReadSourcePackages verbosity distDirLayout-                                 projectConfigShared-                                 projectConfigBuildOnly-                                 pkgLocations----- | Return an up-to-date elaborated install plan.------ Two variants of the install plan are returned: with and without packages--- from the store. That is, the \"improved\" plan where source packages are--- replaced by pre-existing installed packages from the store (when their ids--- match), and also the original elaborated plan which uses primarily source--- packages.---- The improved plan is what we use for building, but the original elaborated--- plan is useful for reporting and configuration. For example the @freeze@--- command needs the source package info to know about flag choices and--- dependencies of executables and setup scripts.----rebuildInstallPlan :: Verbosity-                   -> DistDirLayout -> CabalDirLayout-                   -> ProjectConfig-                   -> [PackageSpecifier UnresolvedSourcePackage]-                   -> IO ( ElaboratedInstallPlan  -- with store packages-                         , ElaboratedInstallPlan  -- with source packages-                         , ElaboratedSharedConfig-                         , IndexUtils.TotalIndexState-                         , IndexUtils.ActiveRepos-                         )-                      -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@-rebuildInstallPlan verbosity-                   distDirLayout@DistDirLayout {-                     distProjectRootDirectory,-                     distProjectCacheFile-                   }-                   CabalDirLayout {-                     cabalStoreDirLayout-                   } = \projectConfig localPackages ->-    runRebuild distProjectRootDirectory $ do-    progsearchpath <- liftIO $ getSystemSearchPath-    let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty }--    -- The overall improved plan is cached-    rerunIfChanged verbosity fileMonitorImprovedPlan-                   -- react to changes in the project config,-                   -- the package .cabal files and the path-                   (projectConfigMonitored, localPackages, progsearchpath) $ do--      -- And so is the elaborated plan that the improved plan based on-      (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <--        rerunIfChanged verbosity fileMonitorElaboratedPlan-                       (projectConfigMonitored, localPackages,-                        progsearchpath) $ do--          compilerEtc   <- phaseConfigureCompiler projectConfig-          _             <- phaseConfigurePrograms projectConfig compilerEtc-          (solverPlan, pkgConfigDB, totalIndexState, activeRepos)-                        <- phaseRunSolver         projectConfig-                                                  compilerEtc-                                                  localPackages-          (elaboratedPlan,-           elaboratedShared) <- phaseElaboratePlan projectConfig-                                                   compilerEtc pkgConfigDB-                                                   solverPlan-                                                   localPackages--          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared-          return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)--      -- The improved plan changes each time we install something, whereas-      -- the underlying elaborated plan only changes when input config-      -- changes, so it's worth caching them separately.-      improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared--      return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)--  where-    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"-    fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"-    fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"-    fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"-    fileMonitorImprovedPlan   = newFileMonitorInCacheDir "improved-plan"--    newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b-    newFileMonitorInCacheDir  = newFileMonitor . distProjectCacheFile---    -- Configure the compiler we're using.-    ---    -- This is moderately expensive and doesn't change that often so we cache-    -- it independently.-    ---    phaseConfigureCompiler :: ProjectConfig-                           -> Rebuild (Compiler, Platform, ProgramDb)-    phaseConfigureCompiler ProjectConfig {-                             projectConfigShared = ProjectConfigShared {-                               projectConfigHcFlavor,-                               projectConfigHcPath,-                               projectConfigHcPkg-                             },-                             projectConfigLocalPackages = PackageConfig {-                               packageConfigProgramPaths,-                               packageConfigProgramArgs,-                               packageConfigProgramPathExtra-                             }-                           } = do-        progsearchpath <- liftIO $ getSystemSearchPath-        rerunIfChanged verbosity fileMonitorCompiler-                       (hcFlavor, hcPath, hcPkg, progsearchpath,-                        packageConfigProgramPaths,-                        packageConfigProgramArgs,-                        packageConfigProgramPathExtra) $ do--          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."-          result@(_, _, progdb') <- liftIO $-            Cabal.configCompilerEx-              hcFlavor hcPath hcPkg-              progdb verbosity--        -- Note that we added the user-supplied program locations and args-        -- for /all/ programs, not just those for the compiler prog and-        -- compiler-related utils. In principle we don't know which programs-        -- the compiler will configure (and it does vary between compilers).-        -- We do know however that the compiler will only configure the-        -- programs it cares about, and those are the ones we monitor here.-          monitorFiles (programsMonitorFiles progdb')--          return result-      where-        hcFlavor = flagToMaybe projectConfigHcFlavor-        hcPath   = flagToMaybe projectConfigHcPath-        hcPkg    = flagToMaybe projectConfigHcPkg-        progdb   =-            userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))-          . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))-          . modifyProgramSearchPath-              (++ [ ProgramSearchPathDir dir-                  | dir <- fromNubList packageConfigProgramPathExtra ])-          $ defaultProgramDb---    -- Configuring other programs.-    ---    -- Having configred the compiler, now we configure all the remaining-    -- programs. This is to check we can find them, and to monitor them for-    -- changes.-    ---    -- TODO: [required eventually] we don't actually do this yet.-    ---    -- We rely on the fact that the previous phase added the program config for-    -- all local packages, but that all the programs configured so far are the-    -- compiler program or related util programs.-    ---    phaseConfigurePrograms :: ProjectConfig-                           -> (Compiler, Platform, ProgramDb)-                           -> Rebuild ()-    phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do-        -- Users are allowed to specify program locations independently for-        -- each package (e.g. to use a particular version of a pre-processor-        -- for some packages). However they cannot do this for the compiler-        -- itself as that's just not going to work. So we check for this.-        liftIO $ checkBadPerPackageCompilerPaths-          (configuredPrograms compilerprogdb)-          (getMapMappend (projectConfigSpecificPackage projectConfig))--        --TODO: [required eventually] find/configure other programs that the-        -- user specifies.--        --TODO: [required eventually] find/configure all build-tools-        -- but note that some of them may be built as part of the plan.---    -- Run the solver to get the initial install plan.-    -- This is expensive so we cache it independently.-    ---    phaseRunSolver-        :: ProjectConfig-        -> (Compiler, Platform, ProgramDb)-        -> [PackageSpecifier UnresolvedSourcePackage]-        -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)-    phaseRunSolver projectConfig@ProjectConfig {-                     projectConfigShared,-                     projectConfigBuildOnly-                   }-                   (compiler, platform, progdb)-                   localPackages =-        rerunIfChanged verbosity fileMonitorSolverPlan-                       (solverSettings,-                        localPackages, localPackagesEnabledStanzas,-                        compiler, platform, programDbSignature progdb) $ do--          installedPkgIndex <- getInstalledPackages verbosity-                                                    compiler progdb platform-                                                    corePackageDbs-          (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx-              (solverSettingIndexState solverSettings)-              (solverSettingActiveRepos solverSettings)-          pkgConfigDB       <- getPkgConfigDb verbosity progdb--          --TODO: [code cleanup] it'd be better if the Compiler contained the-          -- ConfiguredPrograms that it needs, rather than relying on the progdb-          -- since we don't need to depend on all the programs here, just the-          -- ones relevant for the compiler.--          liftIO $ do-            solver <- chooseSolver verbosity-                                   (solverSettingSolver solverSettings)-                                   (compilerInfo compiler)--            notice verbosity "Resolving dependencies..."-            plan <- foldProgress logMsg (die' verbosity) return $-              planPackages verbosity compiler platform solver solverSettings-                           installedPkgIndex sourcePkgDb pkgConfigDB-                           localPackages localPackagesEnabledStanzas-            return (plan, pkgConfigDB, tis, ar)-      where-        corePackageDbs = [GlobalPackageDB]-        withRepoCtx    = projectConfigWithSolverRepoContext verbosity-                           projectConfigShared-                           projectConfigBuildOnly-        solverSettings = resolveSolverSettings projectConfig-        logMsg message rest = debugNoWrap verbosity message >> rest--        localPackagesEnabledStanzas =-          Map.fromList-            [ (pkgname, stanzas)-            | pkg <- localPackages-              -- TODO: misnormer: we should separate-              -- builtin/global/inplace/local packages-              -- and packages explicitly mentioned in the project-              ---            , let pkgname            = pkgSpecifierTarget pkg-                  testsEnabled       = lookupLocalPackageConfig-                                         packageConfigTests-                                         projectConfig pkgname-                  benchmarksEnabled  = lookupLocalPackageConfig-                                         packageConfigBenchmarks-                                         projectConfig pkgname-                  isLocal = isJust (shouldBeLocal pkg)-                  stanzas-                    | isLocal = Map.fromList $-                      [ (TestStanzas, enabled)-                      | enabled <- flagToList testsEnabled ] ++-                      [ (BenchStanzas , enabled)-                      | enabled <- flagToList benchmarksEnabled ]-                    | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ]-            ]--    -- Elaborate the solver's install plan to get a fully detailed plan. This-    -- version of the plan has the final nix-style hashed ids.-    ---    phaseElaboratePlan :: ProjectConfig-                       -> (Compiler, Platform, ProgramDb)-                       -> PkgConfigDb-                       -> SolverInstallPlan-                       -> [PackageSpecifier (SourcePackage (PackageLocation loc))]-                       -> Rebuild ( ElaboratedInstallPlan-                                  , ElaboratedSharedConfig )-    phaseElaboratePlan ProjectConfig {-                         projectConfigShared,-                         projectConfigAllPackages,-                         projectConfigLocalPackages,-                         projectConfigSpecificPackage,-                         projectConfigBuildOnly-                       }-                       (compiler, platform, progdb) pkgConfigDB-                       solverPlan localPackages = do--        liftIO $ debug verbosity "Elaborating the install plan..."--        sourcePackageHashes <--          rerunIfChanged verbosity fileMonitorSourceHashes-                         (packageLocationsSignature solverPlan) $-            getPackageSourceHashes verbosity withRepoCtx solverPlan--        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler-        (elaboratedPlan, elaboratedShared)-          <- liftIO . runLogProgress verbosity $-              elaborateInstallPlan-                verbosity-                platform compiler progdb pkgConfigDB-                distDirLayout-                cabalStoreDirLayout-                solverPlan-                localPackages-                sourcePackageHashes-                defaultInstallDirs-                projectConfigShared-                projectConfigAllPackages-                projectConfigLocalPackages-                (getMapMappend projectConfigSpecificPackage)-        let instantiatedPlan-              = instantiateInstallPlan-                  cabalStoreDirLayout-                  defaultInstallDirs-                  elaboratedShared-                  elaboratedPlan-        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)-        return (instantiatedPlan, elaboratedShared)-      where-        withRepoCtx = projectConfigWithSolverRepoContext verbosity-                        projectConfigShared-                        projectConfigBuildOnly--    -- Update the files we maintain that reflect our current build environment.-    -- In particular we maintain a JSON representation of the elaborated-    -- install plan (but not the improved plan since that reflects the state-    -- of the build rather than just the input environment).-    ---    phaseMaintainPlanOutputs :: ElaboratedInstallPlan-                             -> ElaboratedSharedConfig-                             -> Rebuild ()-    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do-        debug verbosity "Updating plan.json"-        writePlanExternalRepresentation-          distDirLayout-          elaboratedPlan-          elaboratedShared---    -- Improve the elaborated install plan. The elaborated plan consists-    -- mostly of source packages (with full nix-style hashed ids). Where-    -- corresponding installed packages already exist in the store, replace-    -- them in the plan.-    ---    -- Note that we do monitor the store's package db here, so we will redo-    -- this improvement phase when the db changes -- including as a result of-    -- executing a plan and installing things.-    ---    phaseImprovePlan :: ElaboratedInstallPlan-                     -> ElaboratedSharedConfig-                     -> Rebuild ElaboratedInstallPlan-    phaseImprovePlan elaboratedPlan elaboratedShared = do--        liftIO $ debug verbosity "Improving the install plan..."-        storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid-        let improvedPlan = improveInstallPlanWithInstalledPackages-                             storePkgIdSet-                             elaboratedPlan-        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)-        -- TODO: [nice to have] having checked which packages from the store-        -- we're using, it may be sensible to sanity check those packages-        -- by loading up the compiler package db and checking everything-        -- matches up as expected, e.g. no dangling deps, files deleted.-        return improvedPlan-      where-        compid = compilerId (pkgConfigCompiler elaboratedShared)---programsMonitorFiles :: ProgramDb -> [MonitorFilePath]-programsMonitorFiles progdb =-    [ monitor-    | prog    <- configuredPrograms progdb-    , monitor <- monitorFileSearchPath (programMonitorFiles prog)-                                       (programPath prog)-    ]---- | Select the bits of a 'ProgramDb' to monitor for value changes.--- Use 'programsMonitorFiles' for the files to monitor.----programDbSignature :: ProgramDb -> [ConfiguredProgram]-programDbSignature progdb =-    [ prog { programMonitorFiles = []-           , programOverrideEnv  = filter ((/="PATH") . fst)-                                          (programOverrideEnv prog) }-    | prog <- configuredPrograms progdb ]--getInstalledPackages :: Verbosity-                     -> Compiler -> ProgramDb -> Platform-                     -> PackageDBStack-                     -> Rebuild InstalledPackageIndex-getInstalledPackages verbosity compiler progdb platform packagedbs = do-    monitorFiles . map monitorFileOrDirectory-      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles-                    verbosity compiler-                    packagedbs progdb platform)-    liftIO $ IndexUtils.getInstalledPackages-               verbosity compiler-               packagedbs progdb--{----TODO: [nice to have] use this but for sanity / consistency checking-getPackageDBContents :: Verbosity-                     -> Compiler -> ProgramDb -> Platform-                     -> PackageDB-                     -> Rebuild InstalledPackageIndex-getPackageDBContents verbosity compiler progdb platform packagedb = do-    monitorFiles . map monitorFileOrDirectory-      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles-                    verbosity compiler-                    [packagedb] progdb platform)-    liftIO $ do-      createPackageDBIfMissing verbosity compiler progdb packagedb-      Cabal.getPackageDBContents verbosity compiler-                                 packagedb progdb--}--getSourcePackages-    :: Verbosity-    -> (forall a. (RepoContext -> IO a) -> IO a)-    -> Maybe IndexUtils.TotalIndexState-    -> Maybe IndexUtils.ActiveRepos-    -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)-getSourcePackages verbosity withRepoCtx idxState activeRepos = do-    (sourcePkgDbWithTIS, repos) <--      liftIO $-        withRepoCtx $ \repoctx -> do-          sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos-          return (sourcePkgDbWithTIS, repoContextRepos repoctx)--    traverse_ needIfExists-        . IndexUtils.getSourcePackagesMonitorFiles-        $ repos-    return sourcePkgDbWithTIS---getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb-getPkgConfigDb verbosity progdb = do-    dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb-    -- Just monitor the dirs so we'll notice new .pc files.-    -- Alternatively we could monitor all the .pc files too.-    traverse_ monitorDirectoryStatus dirs-    liftIO $ readPkgConfigDb verbosity progdb----- | Select the config values to monitor for changes package source hashes.-packageLocationsSignature :: SolverInstallPlan-                          -> [(PackageId, PackageLocation (Maybe FilePath))]-packageLocationsSignature solverPlan =-    [ (packageId pkg, srcpkgSource pkg)-    | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})-        <- SolverInstallPlan.toList solverPlan-    ]----- | Get the 'HashValue' for all the source packages where we use hashes,--- and download any packages required to do so.------ Note that we don't get hashes for local unpacked packages.----getPackageSourceHashes :: Verbosity-                       -> (forall a. (RepoContext -> IO a) -> IO a)-                       -> SolverInstallPlan-                       -> Rebuild (Map PackageId PackageSourceHash)-getPackageSourceHashes verbosity withRepoCtx solverPlan = do--    -- Determine if and where to get the package's source hash from.-    ---    let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]-        allPkgLocations =-          [ (packageId pkg, srcpkgSource pkg)-          | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})-              <- SolverInstallPlan.toList solverPlan ]--        -- Tarballs that were local in the first place.-        -- We'll hash these tarball files directly.-        localTarballPkgs :: [(PackageId, FilePath)]-        localTarballPkgs =-          [ (pkgid, tarball)-          | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ]--        -- Tarballs from remote URLs. We must have downloaded these already-        -- (since we extracted the .cabal file earlier)-        remoteTarballPkgs =-          [ (pkgid, tarball)-          | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ]--        -- tarballs from source-repository-package stanzas-        sourceRepoTarballPkgs =-          [ (pkgid, tarball)-          | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ]--        -- Tarballs from repositories, either where the repository provides-        -- hashes as part of the repo metadata, or where we will have to-        -- download and hash the tarball.-        repoTarballPkgsWithMetadata    :: [(PackageId, Repo)]-        repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]-        (repoTarballPkgsWithMetadata,-         repoTarballPkgsWithoutMetadata) =-          partitionEithers-          [ case repo of-              RepoSecure{} -> Left  (pkgid, repo)-              _            -> Right (pkgid, repo)-          | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]--    -- For tarballs from repos that do not have hashes available we now have-    -- to check if the packages were downloaded already.-    ---    (repoTarballPkgsToDownload,-     repoTarballPkgsDownloaded)-      <- fmap partitionEithers $-         liftIO $ sequence-           [ do mtarball <- checkRepoTarballFetched repo pkgid-                case mtarball of-                  Nothing      -> return (Left  (pkgid, repo))-                  Just tarball -> return (Right (pkgid, tarball))-           | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]--    (hashesFromRepoMetadata,-     repoTarballPkgsNewlyDownloaded) <--      -- Avoid having to initialise the repository (ie 'withRepoCtx') if we-      -- don't have to. (The main cost is configuring the http client.)-      if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata-      then return (Map.empty, [])-      else liftIO $ withRepoCtx $ \repoctx -> do--      -- For tarballs from repos that do have hashes available as part of the-      -- repo metadata we now load up the index for each repo and retrieve-      -- the hashes for the packages-      ---      hashesFromRepoMetadata <--        Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions-        fmap (Map.fromList . concat) $-        sequence-          -- Reading the repo index is expensive so we group the packages by repo-          [ repoContextWithSecureRepo repoctx repo $ \secureRepo ->-              Sec.withIndex secureRepo $ \repoIndex ->-                sequence-                  [ do hash <- Sec.trusted <$> -- strip off Trusted tag-                               Sec.indexLookupHash repoIndex pkgid-                       -- Note that hackage-security currently uses SHA256-                       -- but this API could in principle give us some other-                       -- choice in future.-                       return (pkgid, hashFromTUF hash)-                  | pkgid <- pkgids ]-          | (repo, pkgids) <--                map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp)))-              . NE.groupBy ((==)    `on` (remoteRepoName . repoRemote . snd))-              . sortBy  (compare `on` (remoteRepoName . repoRemote . snd))-              $ repoTarballPkgsWithMetadata-          ]--      -- For tarballs from repos that do not have hashes available, download-      -- the ones we previously determined we need.-      ---      repoTarballPkgsNewlyDownloaded <--        sequence-          [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid-               return (pkgid, tarball)-          | (pkgid, repo) <- repoTarballPkgsToDownload ]--      return (hashesFromRepoMetadata,-              repoTarballPkgsNewlyDownloaded)--    -- Hash tarball files for packages where we have to do that. This includes-    -- tarballs that were local in the first place, plus tarballs from repos,-    -- either previously cached or freshly downloaded.-    ---    let allTarballFilePkgs :: [(PackageId, FilePath)]-        allTarballFilePkgs = localTarballPkgs-                          ++ remoteTarballPkgs-                          ++ sourceRepoTarballPkgs-                          ++ repoTarballPkgsDownloaded-                          ++ repoTarballPkgsNewlyDownloaded-    hashesFromTarballFiles <- liftIO $-      fmap Map.fromList $-      sequence-        [ do srchash <- readFileHashValue tarball-             return (pkgid, srchash)-        | (pkgid, tarball) <- allTarballFilePkgs-        ]-    monitorFiles [ monitorFile tarball-                 | (_pkgid, tarball) <- allTarballFilePkgs ]--    -- Return the combination-    return $! hashesFromRepoMetadata-           <> hashesFromTarballFiles----- --------------------------------------------------------------- * Installation planning--- --------------------------------------------------------------planPackages :: Verbosity-             -> Compiler-             -> Platform-             -> Solver -> SolverSettings-             -> InstalledPackageIndex-             -> SourcePackageDb-             -> PkgConfigDb-             -> [PackageSpecifier UnresolvedSourcePackage]-             -> Map PackageName (Map OptionalStanza Bool)-             -> Progress String String SolverInstallPlan-planPackages verbosity comp platform solver SolverSettings{..}-             installedPkgIndex sourcePkgDb pkgConfigDB-             localPackages pkgStanzasEnable =--    resolveDependencies-      platform (compilerInfo comp)-      pkgConfigDB solver-      resolverParams--  where--    --TODO: [nice to have] disable multiple instances restriction in-    -- the solver, but then make sure we can cope with that in the-    -- output.-    resolverParams =--        setMaxBackjumps solverSettingMaxBackjumps--      . setIndependentGoals solverSettingIndependentGoals--      . setReorderGoals solverSettingReorderGoals--      . setCountConflicts solverSettingCountConflicts--      . setFineGrainedConflicts solverSettingFineGrainedConflicts--      . setMinimizeConflictSet solverSettingMinimizeConflictSet--        --TODO: [required eventually] should only be configurable for-        --custom installs-   -- . setAvoidReinstalls solverSettingAvoidReinstalls--        --TODO: [required eventually] should only be configurable for-        --custom installs-   -- . setShadowPkgs solverSettingShadowPkgs--      . setStrongFlags solverSettingStrongFlags--      . setAllowBootLibInstalls solverSettingAllowBootLibInstalls--      . setOnlyConstrained solverSettingOnlyConstrained--      . setSolverVerbosity verbosity--        --TODO: [required eventually] decide if we need to prefer-        -- installed for global packages, or prefer latest even for-        -- global packages. Perhaps should be configurable but with a-        -- different name than "upgrade-dependencies".-      . setPreferenceDefault PreferLatestForSelected-                           {-(if solverSettingUpgradeDeps-                                then PreferAllLatest-                                else PreferLatestForSelected)-}--      . removeLowerBounds solverSettingAllowOlder-      . removeUpperBounds solverSettingAllowNewer--      . addDefaultSetupDependencies (defaultSetupDeps comp platform-                                   . PD.packageDescription-                                   . srcpkgDescription)--      . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint-      . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint--      . addPreferences-          -- preferences from the config file or command line-          [ PackageVersionPreference name ver-          | PackageVersionConstraint name ver <- solverSettingPreferences ]--      . addConstraints-          -- version constraints from the config file or command line-            [ LabeledPackageConstraint (userToPackageConstraint pc) src-            | (pc, src) <- solverSettingConstraints ]--      . addPreferences-          -- enable stanza preference where the user did not specify-          [ PackageStanzasPreference pkgname stanzas-          | pkg <- localPackages-          , let pkgname = pkgSpecifierTarget pkg-                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable-                stanzas = [ stanza | stanza <- [minBound..maxBound]-                          , Map.lookup stanza stanzaM == Nothing ]-          , not (null stanzas)-          ]--      . addConstraints-          -- enable stanza constraints where the user asked to enable-          [ LabeledPackageConstraint-              (PackageConstraint (scopeToplevel pkgname)-                                 (PackagePropertyStanzas stanzas))-              ConstraintSourceConfigFlagOrTarget-          | pkg <- localPackages-          , let pkgname = pkgSpecifierTarget pkg-                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable-                stanzas = [ stanza | stanza <- [minBound..maxBound]-                          , Map.lookup stanza stanzaM == Just True ]-          , not (null stanzas)-          ]--      . addConstraints-          --TODO: [nice to have] should have checked at some point that the-          -- package in question actually has these flags.-          [ LabeledPackageConstraint-              (PackageConstraint (scopeToplevel pkgname)-                                 (PackagePropertyFlags flags))-              ConstraintSourceConfigFlagOrTarget-          | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]--      . addConstraints-          --TODO: [nice to have] we have user-supplied flags for unspecified-          -- local packages (as well as specific per-package flags). For the-          -- former we just apply all these flags to all local targets which-          -- is silly. We should check if the flags are appropriate.-          [ LabeledPackageConstraint-              (PackageConstraint (scopeToplevel pkgname)-                                 (PackagePropertyFlags flags))-              ConstraintSourceConfigFlagOrTarget-          | let flags = solverSettingFlagAssignment-          , not (PD.nullFlagAssignment flags)-          , pkg <- localPackages-          , let pkgname = pkgSpecifierTarget pkg ]--      $ stdResolverParams--    stdResolverParams =-      -- Note: we don't use the standardInstallPolicy here, since that uses-      -- its own addDefaultSetupDependencies that is not appropriate for us.-      basicInstallPolicy-        installedPkgIndex sourcePkgDb-        localPackages--    -- While we can talk to older Cabal versions (we need to be able to-    -- do so for custom Setup scripts that require older Cabal lib-    -- versions), we have problems talking to some older versions that-    -- don't support certain features.-    ---    -- For example, Cabal-1.16 and older do not know about build targets.-    -- Even worse, 1.18 and older only supported the --constraint flag-    -- with source package ids, not --dependency with installed package-    -- ids. That is bad because we cannot reliably select the right-    -- dependencies in the presence of multiple instances (i.e. the-    -- store). See issue #3932. So we require Cabal 1.20 as a minimum.-    ---    -- Moreover, lib:Cabal generally only supports the interface of-    -- current and past compilers; in fact recent lib:Cabal versions-    -- will warn when they encounter a too new or unknown GHC compiler-    -- version (c.f. #415). To avoid running into unsupported-    -- configurations we encode the compatibility matrix as lower-    -- bounds on lib:Cabal here (effectively corresponding to the-    -- respective major Cabal version bundled with the respective GHC-    -- release).-    ---    -- GHC 9.0   needs  Cabal >= 3.4-    -- GHC 8.10  needs  Cabal >= 3.2-    -- GHC 8.8   needs  Cabal >= 3.0-    -- GHC 8.6   needs  Cabal >= 2.4-    -- GHC 8.4   needs  Cabal >= 2.2-    -- GHC 8.2   needs  Cabal >= 2.0-    -- GHC 8.0   needs  Cabal >= 1.24-    -- GHC 7.10  needs  Cabal >= 1.22-    ---    -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is-    -- the absolute lower bound)-    ---    -- TODO: long-term, this compatibility matrix should be-    --       stored as a field inside 'Distribution.Compiler.Compiler'-    setupMinCabalVersionConstraint-      | isGHC, compVer >= mkVersion [9,0]  = mkVersion [3,4]-      | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2]-      | isGHC, compVer >= mkVersion [8,8]  = mkVersion [3,0]-      | isGHC, compVer >= mkVersion [8,6]  = mkVersion [2,4]-      | isGHC, compVer >= mkVersion [8,4]  = mkVersion [2,2]-      | isGHC, compVer >= mkVersion [8,2]  = mkVersion [2,0]-      | isGHC, compVer >= mkVersion [8,0]  = mkVersion [1,24]-      | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22]-      | otherwise                          = mkVersion [1,20]-      where-        isGHC    = compFlav `elem` [GHC,GHCJS]-        compFlav = compilerFlavor comp-        compVer  = compilerVersion comp--    -- As we can't predict the future, we also place a global upper-    -- bound on the lib:Cabal version we know how to interact with:-    ---    -- The upper bound is computed by incrementing the current major-    -- version twice in order to allow for the current version, as-    -- well as the next adjacent major version (one of which will not-    -- be released, as only "even major" versions of Cabal are-    -- released to Hackage or bundled with proper GHC releases).-    ---    -- For instance, if the current version of cabal-install is an odd-    -- development version, e.g.  Cabal-2.1.0.0, then we impose an-    -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a-    -- stable/release even version, e.g. Cabal-2.2.1.0, the upper-    -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility-    -- when dealing with development snapshots of Cabal and cabal-install.-    ---    setupMaxCabalVersionConstraint =-      alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion----------------------------------------------------------------------------------- * Install plan post-processing----------------------------------------------------------------------------------- This phase goes from the InstallPlan we get from the solver and has to--- make an elaborated install plan.------ We go in two steps:------  1. elaborate all the source packages that the solver has chosen.---  2. swap source packages for pre-existing installed packages wherever---     possible.------ We do it in this order, elaborating and then replacing, because the easiest--- way to calculate the installed package ids used for the replacement step is--- from the elaborated configuration for each package.-------------------------------------------------------------------------------------- * Install plan elaboration----------------------------------------------------------------------------------- Note [SolverId to ConfiguredId]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Dependency solving is a per package affair, so after we're done, we--- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps'--- and 'solverPkgExeDeps' what packages provide the libraries and executables--- needed by each component of the package (phew!)  For example, if I have------      library---          build-depends: lib---          build-tool-depends: pkg:exe1---          build-tools: alex------ After dependency solving, I find out that this library component has--- library dependencies on lib-0.2, and executable dependencies on pkg-0.1--- and alex-0.3 (other components of the package may have different--- dependencies).  Note that I've "lost" the knowledge that I depend--- *specifically* on the exe1 executable from pkg.------ So, we have a this graph of packages, and we need to transform it into--- a graph of components which we are actually going to build.  In particular:------ NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage)--- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId)------ In both cases, what was previously a single node/edge may turn into multiple--- nodes/edges.  Multiple components, because there may be multiple components--- in a package; multiple component deps, because we may depend upon multiple--- executables from the same package (and maybe, some day, multiple libraries--- from the same package.)------ Let's talk about how to do this transformation. Naively, we might consider--- just processing each package, converting it into (zero or) one or more--- components.  But we also have to update the edges; this leads to--- two complications:------      1. We don't know what the ConfiguredId of a component is until---      we've configured it, but we cannot configure a component unless---      we know the ConfiguredId of all its dependencies.  Thus, we must---      process the 'SolverInstallPlan' in topological order.------      2. When we process a package, we know the SolverIds of its---      dependencies, but we have to do some work to turn these into---      ConfiguredIds.  For example, in the case of build-tool-depends, the---      SolverId isn't enough to uniquely determine the ConfiguredId we should---      elaborate to: we have to look at the executable name attached to---      the package name in the package description to figure it out.---      At the same time, we NEED to use the SolverId, because there might---      be multiple versions of the same package in the build plan---      (due to setup dependencies); we can't just look up the package name---      from the package description.------ We can adopt the following strategy:------      * When a package is transformed into components, record---        a mapping from SolverId to ALL of the components---        which were elaborated.------      * When we look up an edge, we use our knowledge of the---        component name to *filter* the list of components into---        the ones we actually wanted to refer to.------ By the way, we can tell that SolverInstallPlan is not the "right" type--- because a SolverId cannot adequately represent all possible dependency--- solver states: we may need to record foo-0.1 multiple times in--- the solver install plan with different dependencies.  This imprecision in the--- type currently doesn't cause any problems because the dependency solver--- continues to enforce the single instance restriction regardless of compiler--- version.  The right way to solve this is to come up with something very much--- like a 'ConfiguredId', in that it incorporates the version choices of its--- dependencies, but less fine grained.----- | Produce an elaborated install plan using the policy for local builds with--- a nix-style shared store.------ In theory should be able to make an elaborated install plan with a policy--- matching that of the classic @cabal install --user@ or @--global@----elaborateInstallPlan-  :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb-  -> DistDirLayout-  -> StoreDirLayout-  -> SolverInstallPlan-  -> [PackageSpecifier (SourcePackage (PackageLocation loc))]-  -> Map PackageId PackageSourceHash-  -> InstallDirs.InstallDirTemplates-  -> ProjectConfigShared-  -> PackageConfig-  -> PackageConfig-  -> Map PackageName PackageConfig-  -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)-elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB-                     distDirLayout@DistDirLayout{..}-                     storeDirLayout@StoreDirLayout{storePackageDBStack}-                     solverPlan localPackages-                     sourcePackageHashes-                     defaultInstallDirs-                     sharedPackageConfig-                     allPackagesConfig-                     localPackagesConfig-                     perPackageConfig = do-    x <- elaboratedInstallPlan-    return (x, elaboratedSharedConfig)-  where-    elaboratedSharedConfig =-      ElaboratedSharedConfig {-        pkgConfigPlatform      = platform,-        pkgConfigCompiler      = compiler,-        pkgConfigCompilerProgs = compilerprogdb,-        pkgConfigReplOptions   = []-      }--    preexistingInstantiatedPkgs =-        Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))-      where-        f (SolverInstallPlan.PreExisting inst)-            | let ipkg = instSolverPkgIPI inst-            , not (IPI.indefinite ipkg)-            = Just (IPI.installedUnitId ipkg,-                     (FullUnitId (IPI.installedComponentId ipkg)-                                 (Map.fromList (IPI.instantiatedWith ipkg))))-        f _ = Nothing--    elaboratedInstallPlan =-      flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->-        case planpkg of-          SolverInstallPlan.PreExisting pkg ->-            return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]--          SolverInstallPlan.Configured  pkg ->-            let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace"-                            | otherwise                  = Disp.empty-            in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+>-                             quotes (pretty (packageId pkg))) $-               map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg--    -- NB: We don't INSTANTIATE packages at this point.  That's-    -- a post-pass.  This makes it simpler to compute dependencies.-    elaborateSolverToComponents-        :: (SolverId -> [ElaboratedPlanPackage])-        -> SolverPackage UnresolvedPkgLoc-        -> LogProgress [ElaboratedConfiguredPackage]-    elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0)-        = case mkComponentsGraph (elabEnabledSpec elab0) pd of-           Right g -> do-            let src_comps = componentsGraphToList g-            infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon)-                            4 (dispComponentsWithDeps src_comps)-            (_, comps) <- mapAccumM buildComponent-                            (Map.empty, Map.empty, Map.empty)-                            (map fst src_comps)-            let not_per_component_reasons = why_not_per_component src_comps-            if null not_per_component_reasons-                then return comps-                else do checkPerPackageOk comps not_per_component_reasons-                        return [elaborateSolverToPackage spkg g $-                                comps ++ maybeToList setupComponent]-           Left cns ->-            dieProgress $-                hang (text "Dependency cycle between the following components:") 4-                     (vcat (map (text . componentNameStanza) cns))-      where-        -- You are eligible to per-component build if this list is empty-        why_not_per_component g-            = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage-          where-            cuz reason = [text reason]-            -- We have to disable per-component for now with-            -- Configure-type scripts in order to prevent parallel-            -- invocation of the same `./configure` script.-            -- See https://github.com/haskell/cabal/issues/4548-            ---            -- Moreoever, at this point in time, only non-Custom setup scripts-            -- are supported.  Implementing per-component builds with-            -- Custom would require us to create a new 'ElabSetup'-            -- type, and teach all of the code paths how to handle it.-            -- Once you've implemented this, swap it for the code below.-            cuz_buildtype =-                case PD.buildType (elabPkgDescription elab0) of-                    PD.Configure -> cuz "build-type is Configure"-                    PD.Custom -> cuz "build-type is Custom"-                    _         -> []-            -- cabal-format versions prior to 1.8 have different build-depends semantics-            -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8-            -- see, https://github.com/haskell/cabal/issues/4121-            cuz_spec-                | PD.specVersion pd >= CabalSpecV1_8 = []-                | otherwise = cuz "cabal-version is less than 1.8"-            -- In the odd corner case that a package has no components at all-            -- then keep it as a whole package, since otherwise it turns into-            -- 0 component graph nodes and effectively vanishes. We want to-            -- keep it around at least for error reporting purposes.-            cuz_length-                | length g > 0 = []-                | otherwise    = cuz "there are no buildable components"-            -- For ease of testing, we let per-component builds be toggled-            -- at the top level-            cuz_flag-                | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig)-                = []-                | otherwise = cuz "you passed --disable-per-component"-            -- Enabling program coverage introduces odd runtime dependencies-            -- between components.-            cuz_coverage-                | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig)-                = cuz "program coverage is enabled"-                | otherwise = []--        -- | Sometimes a package may make use of features which are only-        -- supported in per-package mode.  If this is the case, we should-        -- give an error when this occurs.-        checkPerPackageOk comps reasons = do-            let is_sublib (CLibName (LSubLibName _)) = True-                is_sublib _ = False-            when (any (matchElabPkg is_sublib) comps) $-                dieProgress $-                    text "Internal libraries only supported with per-component builds." $$-                    text "Per-component builds were disabled because" <+>-                        fsep (punctuate comma reasons)-            -- TODO: Maybe exclude Backpack too--        elab0 = elaborateSolverToCommon spkg-        pkgid = elabPkgSourceId    elab0-        pd    = elabPkgDescription elab0--        -- TODO: This is just a skeleton to get elaborateSolverToPackage-        -- working correctly-        -- TODO: When we actually support building these components, we-        -- have to add dependencies on this from all other components-        setupComponent :: Maybe ElaboratedConfiguredPackage-        setupComponent-            | PD.buildType (elabPkgDescription elab0) == PD.Custom-            = Just elab0 {-                elabModuleShape = emptyModuleShape,-                elabUnitId = notImpl "elabUnitId",-                elabComponentId = notImpl "elabComponentId",-                elabLinkedInstantiatedWith = Map.empty,-                elabInstallDirs = notImpl "elabInstallDirs",-                elabPkgOrComp = ElabComponent (ElaboratedComponent {..})-              }-            | otherwise-            = Nothing-          where-            compSolverName      = CD.ComponentSetup-            compComponentName   = Nothing-            dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0-            compLibDependencies-                = map configuredId dep_pkgs-            compLinkedLibDependencies = notImpl "compLinkedLibDependencies"-            compOrderLibDependencies = notImpl "compOrderLibDependencies"-            -- Not supported:-            compExeDependencies         = []-            compExeDependencyPaths      = []-            compPkgConfigDependencies   = []--            notImpl f =-                error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++-                        f ++ " not implemented yet"---        buildComponent-            :: (ConfiguredComponentMap,-                LinkedComponentMap,-                Map ComponentId FilePath)-            -> Cabal.Component-            -> LogProgress-                ((ConfiguredComponentMap,-                  LinkedComponentMap,-                  Map ComponentId FilePath),-                ElaboratedConfiguredPackage)-        buildComponent (cc_map, lc_map, exe_map) comp =-          addProgressCtx (text "In the stanza" <+>-                          quotes (text (componentNameStanza cname))) $ do--            -- 1. Configure the component, but with a place holder ComponentId.-            cc0 <- toConfiguredComponent-                    pd-                    (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later")-                    (Map.unionWith Map.union external_lib_cc_map cc_map)-                    (Map.unionWith Map.union external_exe_cc_map cc_map)-                    comp---            -- 2. Read out the dependencies from the ConfiguredComponent cc0-            let compLibDependencies =-                    -- Nub because includes can show up multiple times-                    ordNub (map (annotatedIdToConfiguredId . ci_ann_id)-                                (cc_includes cc0))-                compExeDependencies =-                    map annotatedIdToConfiguredId-                        (cc_exe_deps cc0)-                compExeDependencyPaths =-                    [ (annotatedIdToConfiguredId aid', path)-                    | aid' <- cc_exe_deps cc0-                    , Just paths <- [Map.lookup (ann_id aid') exe_map1]-                    , path <- paths ]-                elab_comp = ElaboratedComponent {..}--            -- 3. Construct a preliminary ElaboratedConfiguredPackage,-            -- and use this to compute the component ID.  Fix up cc_id-            -- correctly.-            let elab1 = elab0 {-                        elabPkgOrComp = ElabComponent $ elab_comp-                     }-                cid = case elabBuildStyle elab0 of-                        BuildInplaceOnly ->-                          mkComponentId $-                            prettyShow pkgid ++ "-inplace" ++-                              (case Cabal.componentNameString cname of-                                  Nothing -> ""-                                  Just s -> "-" ++ prettyShow s)-                        BuildAndInstall ->-                          hashedInstalledPackageId-                            (packageHashInputs-                                elaboratedSharedConfig-                                elab1) -- knot tied-                cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) }-            infoProgress $ dispConfiguredComponent cc--            -- 4. Perform mix-in linking-            let lookup_uid def_uid =-                    case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of-                        Just full -> full-                        Nothing -> error ("lookup_uid: " ++ prettyShow def_uid)-            lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0)-                        (Map.union external_lc_map lc_map) cc-            infoProgress $ dispLinkedComponent lc-            -- NB: elab is setup to be the correct form for an-            -- indefinite library, or a definite library with no holes.-            -- We will modify it in 'instantiateInstallPlan' to handle-            -- instantiated packages.--            -- 5. Construct the final ElaboratedConfiguredPackage-            let-                elab2 = elab1 {-                    elabModuleShape = lc_shape lc,-                    elabUnitId      = abstractUnitId (lc_uid lc),-                    elabComponentId = lc_cid lc,-                    elabLinkedInstantiatedWith = Map.fromList (lc_insts lc),-                    elabPkgOrComp = ElabComponent $ elab_comp {-                        compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)),-                        compOrderLibDependencies =-                          ordNub (map (abstractUnitId . ci_id)-                                      (lc_includes lc ++ lc_sig_includes lc))-                      }-                   }-                elab = elab2 {-                    elabInstallDirs = computeInstallDirs-                      storeDirLayout-                      defaultInstallDirs-                      elaboratedSharedConfig-                      elab2-                   }--            -- 6. Construct the updated local maps-            let cc_map'  = extendConfiguredComponentMap cc cc_map-                lc_map'  = extendLinkedComponentMap lc lc_map-                exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map--            return ((cc_map', lc_map', exe_map'), elab)-          where-            compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"-            compOrderLibDependencies = error "buildComponent: compOrderLibDependencies"--            cname = Cabal.componentName comp-            compComponentName = Just cname-            compSolverName = CD.componentNameToComponent cname--            -- NB: compLinkedLibDependencies and-            -- compOrderLibDependencies are defined when we define-            -- 'elab'.-            external_lib_dep_sids = CD.select (== compSolverName) deps0-            external_exe_dep_sids = CD.select (== compSolverName) exe_deps0--            external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids--            -- Combine library and build-tool dependencies, for backwards-            -- compatibility (See issue #5412 and the documentation for-            -- InstallPlan.fromSolverInstallPlan), but prefer the versions-            -- specified as build-tools.-            external_exe_dep_pkgs =-                concatMap mapDep $-                ordNubBy (pkgName . packageId) $-                external_exe_dep_sids ++ external_lib_dep_sids--            external_exe_map = Map.fromList $-                [ (getComponentId pkg, paths)-                | pkg <- external_exe_dep_pkgs-                , let paths = planPackageExePaths pkg ]-            exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map--            external_lib_cc_map = Map.fromListWith Map.union-                                $ map mkCCMapping external_lib_dep_pkgs-            external_exe_cc_map = Map.fromListWith Map.union-                                $ map mkCCMapping external_exe_dep_pkgs-            external_lc_map =-                Map.fromList $ map mkShapeMapping $-                external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids--            compPkgConfigDependencies =-                [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! "-                                            ++ prettyShow pn ++ " from "-                                            ++ prettyShow (elabPkgSourceId elab0))-                                 (pkgConfigDbPkgVersion pkgConfigDB pn))-                | PkgconfigDependency pn _ <- PD.pkgconfigDepends-                                                (Cabal.componentBuildInfo comp) ]--            inplace_bin_dir elab =-                binDirectoryFor-                    distDirLayout-                    elaboratedSharedConfig-                    elab $-                    case Cabal.componentNameString cname of-                             Just n -> prettyShow n-                             Nothing -> ""---    -- | Given a 'SolverId' referencing a dependency on a library, return-    -- the 'ElaboratedPlanPackage' corresponding to the library.  This-    -- returns at most one result.-    elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage])-                         -> SolverId -> [ElaboratedPlanPackage]-    elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep--    -- | Given an 'ElaboratedPlanPackage', return the paths to where the-    -- executables that this package represents would be installed.-    -- The only case where multiple paths can be returned is the inplace-    -- monolithic package one, since there can be multiple exes and each one-    -- has its own directory.-    planPackageExePaths :: ElaboratedPlanPackage -> [FilePath]-    planPackageExePaths =-        -- Pre-existing executables are assumed to be in PATH-        -- already.  In fact, this should be impossible.-        InstallPlan.foldPlanPackage (const []) $ \elab ->-            let-              executables :: [FilePath]-              executables =-                case elabPkgOrComp elab of-                    -- Monolithic mode: all exes of the package-                    ElabPackage _ -> unUnqualComponentName . PD.exeName-                                 <$> PD.executables (elabPkgDescription elab)-                    -- Per-component mode: just the selected exe-                    ElabComponent comp ->-                        case fmap Cabal.componentNameString-                                  (compComponentName comp) of-                            Just (Just n) -> [prettyShow n]-                            _ -> [""]-            in-              binDirectoryFor-                 distDirLayout-                 elaboratedSharedConfig-                 elab-                 <$> executables--    elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc-                             -> ComponentsGraph-                             -> [ElaboratedConfiguredPackage]-                             -> ElaboratedConfiguredPackage-    elaborateSolverToPackage-        pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride)-                           _flags _stanzas _deps0 _exe_deps0)-        compGraph comps =-        -- Knot tying: the final elab includes the-        -- pkgInstalledId, which is calculated by hashing many-        -- of the other fields of the elaboratedPackage.-        elab-      where-        elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg-        elab1 = elab0 {-                elabUnitId = newSimpleUnitId pkgInstalledId,-                elabComponentId = pkgInstalledId,-                elabLinkedInstantiatedWith = Map.empty,-                elabPkgOrComp = ElabPackage $ ElaboratedPackage {..},-                elabModuleShape = modShape-            }-        elab = elab1 {-                elabInstallDirs =-                  computeInstallDirs storeDirLayout-                                     defaultInstallDirs-                                     elaboratedSharedConfig-                                     elab1-            }--        modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of-                        Nothing -> emptyModuleShape-                        Just e -> Ty.elabModuleShape e--        pkgInstalledId-          | shouldBuildInplaceOnly pkg-          = mkComponentId (prettyShow pkgid ++ "-inplace")--          | otherwise-          = assert (isJust elabPkgSourceHash) $-            hashedInstalledPackageId-              (packageHashInputs-                elaboratedSharedConfig-                elab)  -- recursive use of elab--          | otherwise-          = error $ "elaborateInstallPlan: non-inplace package "-                 ++ " is missing a source hash: " ++ prettyShow pkgid--        -- Need to filter out internal dependencies, because they don't-        -- correspond to anything real anymore.-        isExt confid = confSrcId confid /= pkgid-        filterExt  = filter isExt-        filterExt' = filter (isExt . fst)--        pkgLibDependencies-            = buildComponentDeps (filterExt  . compLibDependencies)-        pkgExeDependencies-            = buildComponentDeps (filterExt  . compExeDependencies)-        pkgExeDependencyPaths-            = buildComponentDeps (filterExt' . compExeDependencyPaths)-        -- TODO: Why is this flat?-        pkgPkgConfigDependencies-            = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies--        pkgDependsOnSelfLib-            = CD.fromList [ (CD.componentNameToComponent cn, [()])-                          | Graph.N _ cn _ <- fromMaybe [] mb_closure ]-          where-            mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ]-            -- NB: the sublib case should not occur, because sub-libraries-            -- are not supported without per-component builds-            is_lib (CLibName _) = True-            is_lib _ = False--        buildComponentDeps f-            = CD.fromList [ (compSolverName comp, f comp)-                          | ElaboratedConfiguredPackage{-                                elabPkgOrComp = ElabComponent comp-                            } <- comps-                          ]--        -- NB: This is not the final setting of 'pkgStanzasEnabled'.-        -- See [Sticky enabled testsuites]; we may enable some extra-        -- stanzas opportunistically when it is cheap to do so.-        ---        -- However, we start off by enabling everything that was-        -- requested, so that we can maintain an invariant that-        -- pkgStanzasEnabled is a superset of elabStanzasRequested-        pkgStanzasEnabled  = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested)--    elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc-                            -> ElaboratedConfiguredPackage-    elaborateSolverToCommon-        pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride)-                           flags stanzas deps0 _exe_deps0) =-        elaboratedPackage-      where-        elaboratedPackage = ElaboratedConfiguredPackage {..}--        -- These get filled in later-        elabUnitId          = error "elaborateSolverToCommon: elabUnitId"-        elabComponentId     = error "elaborateSolverToCommon: elabComponentId"-        elabInstantiatedWith = Map.empty-        elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith"-        elabPkgOrComp       = error "elaborateSolverToCommon: elabPkgOrComp"-        elabInstallDirs     = error "elaborateSolverToCommon: elabInstallDirs"-        elabModuleShape     = error "elaborateSolverToCommon: elabModuleShape"--        elabIsCanonical     = True-        elabPkgSourceId     = pkgid-        elabPkgDescription  = case PD.finalizePD-                                    flags elabEnabledSpec (const True)-                                    platform (compilerInfo compiler)-                                    [] gdesc of-                               Right (desc, _) -> desc-                               Left _          -> error "Failed to finalizePD in elaborateSolverToCommon"-        elabFlagAssignment  = flags-        elabFlagDefaults    = PD.mkFlagAssignment-                              [ (Cabal.flagName flag, Cabal.flagDefault flag)-                              | flag <- PD.genPackageFlags gdesc ]--        elabEnabledSpec      = enableStanzas stanzas-        elabStanzasAvailable = Set.fromList stanzas-        elabStanzasRequested =-            -- NB: even if a package stanza is requested, if the package-            -- doesn't actually have any of that stanza we omit it from-            -- the request, to ensure that we don't decide that this-            -- package needs to be rebuilt.  (It needs to be done here,-            -- because the ElaboratedConfiguredPackage is where we test-            -- whether or not there have been changes.)-            Map.fromList $ [ (TestStanzas,  v) | v <- maybeToList tests-                                               , _ <- PD.testSuites elabPkgDescription ]-                        ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks-                                               , _ <- PD.benchmarks elabPkgDescription ]-          where-            tests, benchmarks :: Maybe Bool-            tests      = perPkgOptionMaybe pkgid packageConfigTests-            benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks--        -- This is a placeholder which will get updated by 'pruneInstallPlanPass1'-        -- and 'pruneInstallPlanPass2'.  We can't populate it here-        -- because whether or not tests/benchmarks should be enabled-        -- is heuristically calculated based on whether or not the-        -- dependencies of the test suite have already been installed,-        -- but this function doesn't know what is installed (since-        -- we haven't improved the plan yet), so we do it in another pass.-        -- Check the comments of those functions for more details.-        elabConfigureTargets = []-        elabBuildTargets    = []-        elabTestTargets     = []-        elabBenchTargets    = []-        elabReplTarget      = Nothing-        elabHaddockTargets  = []--        elabBuildHaddocks   =-          perPkgOptionFlag pkgid False packageConfigDocumentation--        elabPkgSourceLocation = srcloc-        elabPkgSourceHash   = Map.lookup pkgid sourcePackageHashes-        elabLocalToProject  = isLocalToProject pkg-        elabBuildStyle      = if shouldBuildInplaceOnly pkg-                                then BuildInplaceOnly else BuildAndInstall-        elabBuildPackageDBStack    = buildAndRegisterDbs-        elabRegisterPackageDBStack = buildAndRegisterDbs--        elabSetupScriptStyle       = packageSetupScriptStyle elabPkgDescription-        elabSetupScriptCliVersion  =-          packageSetupScriptSpecVersion-          elabSetupScriptStyle elabPkgDescription libDepGraph deps0-        elabSetupPackageDBStack    = buildAndRegisterDbs--        buildAndRegisterDbs-          | shouldBuildInplaceOnly pkg = inplacePackageDbs-          | otherwise                  = storePackageDbs--        elabPkgDescriptionOverride = descOverride--        elabVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively-        elabSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary-        elabStaticLib     = perPkgOptionFlag pkgid False packageConfigStaticLib-        elabDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe-        elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe-        elabGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still--        elabProfExe       = perPkgOptionFlag pkgid False packageConfigProf-        elabProfLib       = pkgid `Set.member` pkgsUseProfilingLibrary--        (elabProfExeDetail,-         elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault-                               packageConfigProfDetail-                               packageConfigProfLibDetail-        elabCoverage      = perPkgOptionFlag pkgid False packageConfigCoverage--        elabOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization-        elabSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs-        elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections-        elabStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs-        elabStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes-        elabDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo--        -- Combine the configured compiler prog settings with the user-supplied-        -- config. For the compiler progs any user-supplied config was taken-        -- into account earlier when configuring the compiler so its ok that-        -- our configured settings for the compiler override the user-supplied-        -- config here.-        elabProgramPaths  = Map.fromList-                             [ (programId prog, programPath prog)-                             | prog <- configuredPrograms compilerprogdb ]-                        <> perPkgOptionMapLast pkgid packageConfigProgramPaths-        elabProgramArgs   = Map.fromList-                             [ (programId prog, args)-                             | prog <- configuredPrograms compilerprogdb-                             , let args = programOverrideArgs prog-                             , not (null args)-                             ]-                        <> perPkgOptionMapMappend pkgid packageConfigProgramArgs-        elabProgramPathExtra    = perPkgOptionNubList pkgid packageConfigProgramPathExtra-        elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs-        elabExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs-        elabExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs-        elabExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs-        elabProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix-        elabProgSuffix          = perPkgOptionMaybe pkgid packageConfigProgSuffix---        elabHaddockHoogle       = perPkgOptionFlag pkgid False packageConfigHaddockHoogle-        elabHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml-        elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation-        elabHaddockForeignLibs  = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs-        elabHaddockForHackage   = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage-        elabHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables-        elabHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites-        elabHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks-        elabHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal-        elabHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss-        elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource-        elabHaddockQuickJump    = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump-        elabHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss-        elabHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents--        elabTestMachineLog      = perPkgOptionMaybe pkgid packageConfigTestMachineLog-        elabTestHumanLog        = perPkgOptionMaybe pkgid packageConfigTestHumanLog-        elabTestShowDetails     = perPkgOptionMaybe pkgid packageConfigTestShowDetails-        elabTestKeepTix         = perPkgOptionFlag pkgid False packageConfigTestKeepTix-        elabTestWrapper         = perPkgOptionMaybe pkgid packageConfigTestWrapper-        elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites-        elabTestTestOptions     = perPkgOptionList pkgid packageConfigTestTestOptions--        elabBenchmarkOptions    = perPkgOptionList pkgid packageConfigBenchmarkOptions--    perPkgOptionFlag  :: PackageId -> a ->  (PackageConfig -> Flag a) -> a-    perPkgOptionMaybe :: PackageId ->       (PackageConfig -> Flag a) -> Maybe a-    perPkgOptionList  :: PackageId ->       (PackageConfig -> [a])    -> [a]--    perPkgOptionFlag  pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)-    perPkgOptionMaybe pkgid     f = flagToMaybe (lookupPerPkgOption pkgid f)-    perPkgOptionList  pkgid     f = lookupPerPkgOption pkgid f-    perPkgOptionNubList    pkgid f = fromNubList   (lookupPerPkgOption pkgid f)-    perPkgOptionMapLast    pkgid f = getMapLast    (lookupPerPkgOption pkgid f)-    perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f)--    perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)-      where-        exe = fromFlagOrDefault def bothflag-        lib = fromFlagOrDefault def (bothflag <> libflag)--        bothflag = lookupPerPkgOption pkgid fboth-        libflag  = lookupPerPkgOption pkgid flib--    lookupPerPkgOption :: (Package pkg, Monoid m)-                       => pkg -> (PackageConfig -> m) -> m-    lookupPerPkgOption pkg f =-        -- This is where we merge the options from the project config that-        -- apply to all packages, all project local packages, and to specific-        -- named packages-        global `mappend` local `mappend` perpkg-      where-        global = f allPackagesConfig-        local  | isLocalToProject pkg-               = f localPackagesConfig-               | otherwise-               = mempty-        perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)--    inplacePackageDbs = storePackageDbs-                     ++ [ distPackageDB (compilerId compiler) ]--    storePackageDbs   = storePackageDBStack (compilerId compiler)--    -- For this local build policy, every package that lives in a local source-    -- dir (as opposed to a tarball), or depends on such a package, will be-    -- built inplace into a shared dist dir. Tarball packages that depend on-    -- source dir packages will also get unpacked locally.-    shouldBuildInplaceOnly :: SolverPackage loc -> Bool-    shouldBuildInplaceOnly pkg = Set.member (packageId pkg)-                                            pkgsToBuildInplaceOnly--    pkgsToBuildInplaceOnly :: Set PackageId-    pkgsToBuildInplaceOnly =-        Set.fromList-      $ map packageId-      $ SolverInstallPlan.reverseDependencyClosure-          solverPlan-          (map PlannedId (Set.toList pkgsLocalToProject))--    isLocalToProject :: Package pkg => pkg -> Bool-    isLocalToProject pkg = Set.member (packageId pkg)-                                      pkgsLocalToProject--    pkgsLocalToProject :: Set PackageId-    pkgsLocalToProject =-        Set.fromList (catMaybes (map shouldBeLocal localPackages))-        --TODO: localPackages is a misnomer, it's all project packages-        -- here is where we decide which ones will be local!--    pkgsUseSharedLibrary :: Set PackageId-    pkgsUseSharedLibrary =-        packagesWithLibDepsDownwardClosedProperty needsSharedLib-      where-        needsSharedLib pkg =-            fromMaybe compilerShouldUseSharedLibByDefault-                      (liftM2 (||) pkgSharedLib pkgDynExe)-          where-            pkgid        = packageId pkg-            pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib-            pkgDynExe    = perPkgOptionMaybe pkgid packageConfigDynExe--    --TODO: [code cleanup] move this into the Cabal lib. It's currently open-    -- coded in Distribution.Simple.Configure, but should be made a proper-    -- function of the Compiler or CompilerInfo.-    compilerShouldUseSharedLibByDefault =-      case compilerFlavor compiler of-        GHC   -> GHC.isDynamic compiler-        GHCJS -> GHCJS.isDynamic compiler-        _     -> False--    pkgsUseProfilingLibrary :: Set PackageId-    pkgsUseProfilingLibrary =-        packagesWithLibDepsDownwardClosedProperty needsProfilingLib-      where-        needsProfilingLib pkg =-            fromFlagOrDefault False (profBothFlag <> profLibFlag)-          where-            pkgid        = packageId pkg-            profBothFlag = lookupPerPkgOption pkgid packageConfigProf-            profLibFlag  = lookupPerPkgOption pkgid packageConfigProfLib-            --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe--    libDepGraph = Graph.fromDistinctList $-                    map NonSetupLibDepSolverPlanPackage-                        (SolverInstallPlan.toList solverPlan)--    packagesWithLibDepsDownwardClosedProperty property =-        Set.fromList-      . map packageId-      . fromMaybe []-      $ Graph.closure-          libDepGraph-          [ Graph.nodeKey pkg-          | pkg <- SolverInstallPlan.toList solverPlan-          , property pkg ] -- just the packages that satisfy the property-      --TODO: [nice to have] this does not check the config consistency,-      -- e.g. a package explicitly turning off profiling, but something-      -- depending on it that needs profiling. This really needs a separate-      -- package config validation/resolution pass.--      --TODO: [nice to have] config consistency checking:-      -- + profiling libs & exes, exe needs lib, recursive-      -- + shared libs & exes, exe needs lib, recursive-      -- + vanilla libs & exes, exe needs lib, recursive-      -- + ghci or shared lib needed by TH, recursive, ghc version dependent---- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping--shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId-shouldBeLocal NamedPackage{}              = Nothing-shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of-    LocalUnpackedPackage _ -> Just (packageId pkg)-    _                      -> Nothing---- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'.-matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool-matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p)---- | Get the appropriate 'ComponentName' which identifies an installed--- component.-ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName-ipiComponentName = CLibName . IPI.sourceLibName---- | Given a 'ElaboratedConfiguredPackage', report if it matches a--- 'ComponentName'.-matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool-matchElabPkg p elab =-    case elabPkgOrComp elab of-        ElabComponent comp -> maybe False p (compComponentName comp)-        ElabPackage _ ->-            -- So, what should we do here?  One possibility is to-            -- unconditionally return 'True', because whatever it is-            -- that we're looking for, it better be in this package.-            -- But this is a bit dodgy if the package doesn't actually-            -- have, e.g., a library.  Fortunately, it's not possible-            -- for the build of the library/executables to be toggled-            -- by 'pkgStanzasEnabled', so the only thing we have to-            -- test is if the component in question is *buildable.*-            any (p . componentName)-                (Cabal.pkgBuildableComponents (elabPkgDescription elab))---- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName'--- and 'ComponentName' to the 'ComponentId' that should be used--- in this case.-mkCCMapping :: ElaboratedPlanPackage-            -> (PackageName, Map ComponentName (AnnotatedId ComponentId))-mkCCMapping =-    InstallPlan.foldPlanPackage-       (\ipkg -> (packageName ipkg,-                    Map.singleton (ipiComponentName ipkg)-                                  -- TODO: libify-                                  (AnnotatedId {-                                    ann_id = IPI.installedComponentId ipkg,-                                    ann_pid = packageId ipkg,-                                    ann_cname = IPI.sourceComponentName ipkg-                                  })))-      $ \elab ->-        let mk_aid cn = AnnotatedId {-                            ann_id = elabComponentId elab,-                            ann_pid = packageId elab,-                            ann_cname = cn-                        }-        in (packageName elab,-            case elabPkgOrComp elab of-                ElabComponent comp ->-                    case compComponentName comp of-                        Nothing -> Map.empty-                        Just n  -> Map.singleton n (mk_aid n)-                ElabPackage _ ->-                    Map.fromList $-                        map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn))-                            (Cabal.pkgBuildableComponents (elabPkgDescription elab)))---- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId'--- to the shape of this package, as per mix-in linking.-mkShapeMapping :: ElaboratedPlanPackage-               -> (ComponentId, (OpenUnitId, ModuleShape))-mkShapeMapping dpkg =-    (getComponentId dpkg, (indef_uid, shape))-  where-    (dcid, shape) =-        InstallPlan.foldPlanPackage-            -- Uses Monad (->)-            (liftM2 (,) IPI.installedComponentId shapeInstalledPackage)-            (liftM2 (,) elabComponentId elabModuleShape)-            dpkg-    indef_uid =-        IndefFullUnitId dcid-            (Map.fromList [ (req, OpenModuleVar req)-                          | req <- Set.toList (modShapeRequires shape)])---- | Get the bin\/ directories that a package's executables should reside in.------ The result may be empty if the package does not build any executables.------ The result may have several entries if this is an inplace build of a package--- with multiple executables.-binDirectories-  :: DistDirLayout-  -> ElaboratedSharedConfig-  -> ElaboratedConfiguredPackage-  -> [FilePath]-binDirectories layout config package = case elabBuildStyle package of-  -- quick sanity check: no sense returning a bin directory if we're not going-  -- to put any executables in it, that will just clog up the PATH-  _ | noExecutables -> []-  BuildAndInstall -> [installedBinDirectory package]-  BuildInplaceOnly -> map (root</>) $ case elabPkgOrComp package of-    ElabComponent comp -> case compSolverName comp of-      CD.ComponentExe n -> [prettyShow n]-      _ -> []-    ElabPackage _ -> map (prettyShow . PD.exeName)-                   . PD.executables-                   . elabPkgDescription-                   $ package-  where-  noExecutables = null . PD.executables . elabPkgDescription $ package-  root  =  distBuildDirectory layout (elabDistDirParams config package)-       </> "build"---- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the--- dependency graph considers only dependencies on libraries which are--- NOT from setup dependencies.  Used to compute the set--- of packages needed for profiling and dynamic libraries.-newtype NonSetupLibDepSolverPlanPackage-    = NonSetupLibDepSolverPlanPackage-    { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage }--instance Package NonSetupLibDepSolverPlanPackage where-    packageId = packageId . unNonSetupLibDepSolverPlanPackage--instance IsNode NonSetupLibDepSolverPlanPackage where-    type Key NonSetupLibDepSolverPlanPackage = SolverId-    nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage-    nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg)-        = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg)--type InstS = Map UnitId ElaboratedPlanPackage-type InstM a = State InstS a--getComponentId :: ElaboratedPlanPackage-               -> ComponentId-getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg-getComponentId (InstallPlan.Configured elab) = elabComponentId elab-getComponentId (InstallPlan.Installed elab) = elabComponentId elab--instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan-instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =-    InstallPlan.new (IndependentGoals False)-                    (Graph.fromDistinctList (Map.elems ready_map))-  where-    pkgs = InstallPlan.toList plan--    cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ]--    instantiateUnitId :: ComponentId -> Map ModuleName Module-                      -> InstM DefUnitId-    instantiateUnitId cid insts = state $ \s ->-        case Map.lookup uid s of-            Nothing ->-                -- Knot tied-                let (r, s') = runState (instantiateComponent uid cid insts)-                                       (Map.insert uid r s)-                in (def_uid, Map.insert uid r s')-            Just _ -> (def_uid, s)-      where-        def_uid = mkDefUnitId cid insts-        uid = unDefUnitId def_uid--    instantiateComponent-        :: UnitId -> ComponentId -> Map ModuleName Module-        -> InstM ElaboratedPlanPackage-    instantiateComponent uid cid insts-      | Just planpkg <- Map.lookup cid cmap-      = case planpkg of-          InstallPlan.Configured (elab0@ElaboratedConfiguredPackage-                                    { elabPkgOrComp = ElabComponent comp }) -> do-            deps <- traverse (substUnitId insts)-                         (compLinkedLibDependencies comp)-            let getDep (Module dep_uid _) = [dep_uid]-                elab1 = elab0 {-                    elabUnitId = uid,-                    elabComponentId = cid,-                    elabInstantiatedWith = insts,-                    elabIsCanonical = Map.null insts,-                    elabPkgOrComp = ElabComponent comp {-                        compOrderLibDependencies =-                            (if Map.null insts then [] else [newSimpleUnitId cid]) ++-                            ordNub (map unDefUnitId-                                (deps ++ concatMap getDep (Map.elems insts)))-                    }-                  }-                elab = elab1 {-                    elabInstallDirs = computeInstallDirs storeDirLayout-                                                         defaultInstallDirs-                                                         elaboratedShared-                                                         elab1-                  }-            return $ InstallPlan.Configured elab-          _ -> return planpkg-      | otherwise = error ("instantiateComponent: " ++ prettyShow cid)--    substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId-    substUnitId _ (DefiniteUnitId uid) =-        return uid-    substUnitId subst (IndefFullUnitId cid insts) = do-        insts' <- substSubst subst insts-        instantiateUnitId cid insts'--    -- NB: NOT composition-    substSubst :: Map ModuleName Module-               -> Map ModuleName OpenModule-               -> InstM (Map ModuleName Module)-    substSubst subst insts = traverse (substModule subst) insts--    substModule :: Map ModuleName Module -> OpenModule -> InstM Module-    substModule subst (OpenModuleVar mod_name)-        | Just m <- Map.lookup mod_name subst = return m-        | otherwise = error "substModule: non-closing substitution"-    substModule subst (OpenModule uid mod_name) = do-        uid' <- substUnitId subst uid-        return (Module uid' mod_name)--    indefiniteUnitId :: ComponentId -> InstM UnitId-    indefiniteUnitId cid = do-        let uid = newSimpleUnitId cid-        r <- indefiniteComponent uid cid-        state $ \s -> (uid, Map.insert uid r s)--    indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage-    indefiniteComponent _uid cid-      -- Only need Configured; this phase happens before improvement, so-      -- there shouldn't be any Installed packages here.-      | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap-      , ElabComponent elab_comp <- elabPkgOrComp epkg-      = do -- We need to do a little more processing of the includes: some-           -- of them are fully definite even without substitution.  We-           -- want to build those too; see #5634.-           ---           -- This code mimics similar code in Distribution.Backpack.ReadyComponent;-           -- however, unlike the conversion from LinkedComponent to-           -- ReadyComponent, this transformation is done *without*-           -- changing the type in question; and what we are simply-           -- doing is enforcing tighter invariants on the data-           -- structure in question.  The new invariant is that there-           -- is no IndefFullUnitId in compLinkedLibDependencies that actually-           -- has no holes.  We couldn't specify this invariant when-           -- we initially created the ElaboratedPlanPackage because-           -- we have no way of actually refiying the UnitId into a-           -- DefiniteUnitId (that's what substUnitId does!)-           new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->-             if Set.null (openUnitIdFreeHoles uid)-                then fmap DefiniteUnitId (substUnitId Map.empty uid)-                else return uid-           return $ InstallPlan.Configured epkg {-            elabPkgOrComp = ElabComponent elab_comp {-                compLinkedLibDependencies = new_deps,-                -- I think this is right: any new definite unit ids we-                -- minted in the phase above need to be built before us.-                -- Add 'em in.  This doesn't remove any old dependencies-                -- on the indefinite package; they're harmless.-                compOrderLibDependencies =-                    ordNub $ compOrderLibDependencies elab_comp ++-                             [unDefUnitId d | DefiniteUnitId d <- new_deps]-            }-           }-      | Just planpkg <- Map.lookup cid cmap-      = return planpkg-      | otherwise = error ("indefiniteComponent: " ++ prettyShow cid)--    ready_map = execState work Map.empty--    work = for_ pkgs $ \pkg ->-            case pkg of-                InstallPlan.Configured elab-                    | not (Map.null (elabLinkedInstantiatedWith elab))-                    -> indefiniteUnitId (elabComponentId elab)-                        >> return ()-                _ -> instantiateUnitId (getComponentId pkg) Map.empty-                        >> return ()-------------------------------- Build targets------- Refer to ProjectPlanning.Types for details of these important types:---- data ComponentTarget = ...--- data SubComponentTarget = ...---- One step in the build system is to translate higher level intentions like--- "build this package", "test that package", or "repl that component" into--- a more detailed specification of exactly which components to build (or other--- actions like repl or build docs). This translation is somewhat different for--- different commands. For example "test" for a package will build a different--- set of components than "build". In addition, the translation of these--- intentions can fail. For example "run" for a package is only unambiguous--- when the package has a single executable.------ So we need a little bit of infrastructure to make it easy for the command--- implementations to select what component targets are meant when a user asks--- to do something with a package or component. To do this (and to be able to--- produce good error messages for mistakes and when targets are not available)--- we need to gather and summarise accurate information about all the possible--- targets, both available and unavailable. Then a command implementation can--- decide which of the available component targets should be selected.---- | An available target represents a component within a package that a user--- command could plausibly refer to. In this sense, all the components defined--- within the package are things the user could refer to, whether or not it--- would actually be possible to build that component.------ In particular the available target contains an 'AvailableTargetStatus' which--- informs us about whether it's actually possible to select this component to--- be built, and if not why not. This detail makes it possible for command--- implementations (like @build@, @test@ etc) to accurately report why a target--- cannot be used.------ Note that the type parameter is used to help enforce that command--- implementations can only select targets that can actually be built (by--- forcing them to return the @k@ value for the selected targets).--- In particular 'resolveTargets' makes use of this (with @k@ as--- @('UnitId', ComponentName')@) to identify the targets thus selected.----data AvailableTarget k = AvailableTarget {-       availableTargetPackageId      :: PackageId,-       availableTargetComponentName  :: ComponentName,-       availableTargetStatus         :: AvailableTargetStatus k,-       availableTargetLocalToProject :: Bool-     }-  deriving (Eq, Show, Functor)---- | The status of a an 'AvailableTarget' component. This tells us whether--- it's actually possible to select this component to be built, and if not--- why not.----data AvailableTargetStatus k =-       TargetDisabledByUser   -- ^ When the user does @tests: False@-     | TargetDisabledBySolver -- ^ When the solver could not enable tests-     | TargetNotBuildable     -- ^ When the component has @buildable: False@-     | TargetNotLocal         -- ^ When the component is non-core in a non-local package-     | TargetBuildable k TargetRequested -- ^ The target can or should be built-  deriving (Eq, Ord, Show, Functor)---- | This tells us whether a target ought to be built by default, or only if--- specifically requested. The policy is that components like libraries and--- executables are built by default by @build@, but test suites and benchmarks--- are not, unless this is overridden in the project configuration.----data TargetRequested =-       TargetRequestedByDefault    -- ^ To be built by default-     | TargetNotRequestedByDefault -- ^ Not to be built by default-  deriving (Eq, Ord, Show)---- | Given the install plan, produce the set of 'AvailableTarget's for each--- package-component pair.------ Typically there will only be one such target for each component, but for--- example if we have a plan with both normal and profiling variants of a--- component then we would get both as available targets, or similarly if we--- had a plan that contained two instances of the same version of a package.--- This approach makes it relatively easy to select all instances\/variants--- of a component.----availableTargets :: ElaboratedInstallPlan-                 -> Map (PackageId, ComponentName)-                        [AvailableTarget (UnitId, ComponentName)]-availableTargets installPlan =-    let rs = [ (pkgid, cname, fake, target)-             | pkg <- InstallPlan.toList installPlan-             , (pkgid, cname, fake, target) <- case pkg of-                 InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg-                 InstallPlan.Installed   elab -> availableSourceTargets elab-                 InstallPlan.Configured  elab -> availableSourceTargets elab-             ]-     in Map.union-         (Map.fromListWith (++)-            [ ((pkgid, cname), [target])-            | (pkgid, cname, fake, target) <- rs, not fake])-         (Map.fromList-            [ ((pkgid, cname), [target])-            | (pkgid, cname, fake, target) <- rs, fake])-    -- The normal targets mask the fake ones. We get all instances of the-    -- normal ones and only one copy of the fake ones (as there are many-    -- duplicates of the fake ones). See 'availableSourceTargets' below for-    -- more details on this fake stuff is about.--availableInstalledTargets :: IPI.InstalledPackageInfo-                          -> [(PackageId, ComponentName, Bool,-                               AvailableTarget (UnitId, ComponentName))]-availableInstalledTargets ipkg =-    let unitid = installedUnitId ipkg-        cname  = CLibName LMainLibName-        status = TargetBuildable (unitid, cname) TargetRequestedByDefault-        target = AvailableTarget (packageId ipkg) cname status False-        fake   = False-     in [(packageId ipkg, cname, fake, target)]--availableSourceTargets :: ElaboratedConfiguredPackage-                       -> [(PackageId, ComponentName, Bool,-                            AvailableTarget (UnitId, ComponentName))]-availableSourceTargets elab =-    -- We have a somewhat awkward problem here. We need to know /all/ the-    -- components from /all/ the packages because these are the things that-    -- users could refer to. Unfortunately, at this stage the elaborated install-    -- plan does /not/ contain all components: some components have already-    -- been deleted because they cannot possibly be built. This is the case-    -- for components that are marked @buildable: False@ in their .cabal files.-    -- (It's not unreasonable that the unbuildable components have been pruned-    -- as the plan invariant is considerably simpler if all nodes can be built)-    ---    -- We can recover the missing components but it's not exactly elegant. For-    -- a graph node corresponding to a component we still have the information-    -- about the package that it came from, and this includes the names of-    -- /all/ the other components in the package. So in principle this lets us-    -- find the names of all components, plus full details of the buildable-    -- components.-    ---    -- Consider for example a package with 3 exe components: foo, bar and baz-    -- where foo and bar are buildable, but baz is not. So the plan contains-    -- nodes for the components foo and bar. Now we look at each of these two-    -- nodes and look at the package they come from and the names of the-    -- components in this package. This will give us the names foo, bar and-    -- baz, twice (once for each of the two buildable components foo and bar).-    ---    -- We refer to these reconstructed missing components as fake targets.-    -- It is an invariant that they are not available to be built.-    ---    -- To produce the final set of targets we put the fake targets in a finite-    -- map (thus eliminating the duplicates) and then we overlay that map with-    -- the normal buildable targets. (This is done above in 'availableTargets'.)-    ---    [ (packageId elab, cname, fake, target)-    | component <- pkgComponents (elabPkgDescription elab)-    , let cname  = componentName component-          status = componentAvailableTargetStatus component-          target = AvailableTarget {-                     availableTargetPackageId      = packageId elab,-                     availableTargetComponentName  = cname,-                     availableTargetStatus         = status,-                     availableTargetLocalToProject = elabLocalToProject elab-                   }-          fake   = isFakeTarget cname--    -- TODO: The goal of this test is to exclude "instantiated"-    -- packages as available targets. This means that you can't-    -- ask for a particular instantiated component to be built;-    -- it will only get built by a dependency.  Perhaps the-    -- correct way to implement this is to run selection-    -- prior to instantiating packages.  If you refactor-    -- this, then you can delete this test.-    , elabIsCanonical elab--      -- Filter out some bogus parts of the cross product that are never needed-    , case status of-        TargetBuildable{} | fake -> False-        _                        -> True-    ]-  where-    isFakeTarget cname =-      case elabPkgOrComp elab of-        ElabPackage _               -> False-        ElabComponent elabComponent -> compComponentName elabComponent-                                       /= Just cname--    componentAvailableTargetStatus-      :: Component -> AvailableTargetStatus (UnitId, ComponentName)-    componentAvailableTargetStatus component =-        case componentOptionalStanza $ CD.componentNameToComponent cname of-          -- it is not an optional stanza, so a library, exe or foreign lib-          Nothing-            | not buildable  -> TargetNotBuildable-            | otherwise      -> TargetBuildable (elabUnitId elab, cname)-                                                TargetRequestedByDefault--          -- it is not an optional stanza, so a testsuite or benchmark-          Just stanza ->-            case (Map.lookup stanza (elabStanzasRequested elab),-                  Set.member stanza (elabStanzasAvailable elab)) of-              _ | not withinPlan -> TargetNotLocal-              (Just False,   _)  -> TargetDisabledByUser-              (Nothing,  False)  -> TargetDisabledBySolver-              _ | not buildable  -> TargetNotBuildable-              (Just True, True)  -> TargetBuildable (elabUnitId elab, cname)-                                                    TargetRequestedByDefault-              (Nothing,   True)  -> TargetBuildable (elabUnitId elab, cname)-                                                    TargetNotRequestedByDefault-              (Just True, False) ->-                error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname-      where-        cname      = componentName component-        buildable  = PD.buildable (componentBuildInfo component)-        withinPlan = elabLocalToProject elab-                  || case elabPkgOrComp elab of-                       ElabComponent elabComponent ->-                         compComponentName elabComponent == Just cname-                       ElabPackage _ ->-                         case componentName component of-                           CLibName (LMainLibName) -> True-                           CExeName _ -> True-                           --TODO: what about sub-libs and foreign libs?-                           _          -> False---- | Merge component targets that overlap each other. Specially when we have--- multiple targets for the same component and one of them refers to the whole--- component (rather than a module or file within) then all the other targets--- for that component are subsumed.------ We also allow for information associated with each component target, and--- whenever we targets subsume each other we aggregate their associated info.----nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])]-nubComponentTargets =-    concatMap (wholeComponentOverrides . map snd)-  . groupBy ((==)    `on` fst)-  . sortBy  (compare `on` fst)-  . map (\t@((ComponentTarget cname _, _)) -> (cname, t))-  . map compatSubComponentTargets-  where-    -- If we're building the whole component then that the only target all we-    -- need, otherwise we can have several targets within the component.-    wholeComponentOverrides :: [(ComponentTarget,  a )]-                            -> [(ComponentTarget, [a])]-    wholeComponentOverrides ts =-      case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of-        (t:_) -> [ (t, map snd ts) ]-        []    -> [ (t,[x]) | (t,x) <- ts ]--    -- Not all Cabal Setup.hs versions support sub-component targets, so switch-    -- them over to the whole component-    compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a)-    compatSubComponentTargets target@(ComponentTarget cname _subtarget, x)-      | not setupHsSupportsSubComponentTargets-                  = (ComponentTarget cname WholeComponent, x)-      | otherwise = target--    -- Actually the reality is that no current version of Cabal's Setup.hs-    -- build command actually support building specific files or modules.-    setupHsSupportsSubComponentTargets = False-    -- TODO: when that changes, adjust this test, e.g.-    -- | pkgSetupScriptCliVersion >= Version [x,y] []--pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool-pkgHasEphemeralBuildTargets elab =-    isJust (elabReplTarget elab)- || (not . null) (elabTestTargets elab)- || (not . null) (elabBenchTargets elab)- || (not . null) (elabHaddockTargets elab)- || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab-                      , subtarget /= WholeComponent ]---- | The components that we'll build all of, meaning that after they're built--- we can skip building them again (unlike with building just some modules or--- other files within a component).----elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage-                              -> Set ComponentName-elabBuildTargetWholeComponents elab =-    Set.fromList-      [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ]------------------------------------------------------------------------------------- * Install plan pruning----------------------------------------------------------------------------------- | How 'pruneInstallPlanToTargets' should interpret the per-package--- 'ComponentTarget's: as build, repl or haddock targets.----data TargetAction = TargetActionConfigure-                  | TargetActionBuild-                  | TargetActionRepl-                  | TargetActionTest-                  | TargetActionBench-                  | TargetActionHaddock---- | Given a set of per-package\/per-component targets, take the subset of the--- install plan needed to build those targets. Also, update the package config--- to specify which optional stanzas to enable, and which targets within each--- package to build.------ NB: Pruning happens after improvement, which is important because we--- will prune differently depending on what is already installed (to--- implement "sticky" test suite enabling behavior).----pruneInstallPlanToTargets :: TargetAction-                          -> Map UnitId [ComponentTarget]-                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan-pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan =-    InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)-  . Graph.fromDistinctList-    -- We have to do the pruning in two passes-  . pruneInstallPlanPass2-  . pruneInstallPlanPass1-    -- Set the targets that will be the roots for pruning-  . setRootTargets targetActionType perPkgTargetsMap-  . InstallPlan.toList-  $ elaboratedPlan---- | This is a temporary data type, where we temporarily--- override the graph dependencies of an 'ElaboratedPackage',--- so we can take a closure over them.  We'll throw out the--- overriden dependencies when we're done so it's strictly temporary.------ For 'ElaboratedComponent', this the cached unit IDs always--- coincide with the real thing.-data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId]--instance Package PrunedPackage where-    packageId (PrunedPackage elab _) = packageId elab--instance HasUnitId PrunedPackage where-    installedUnitId = nodeKey--instance IsNode PrunedPackage where-    type Key PrunedPackage = UnitId-    nodeKey (PrunedPackage elab _)  = nodeKey elab-    nodeNeighbors (PrunedPackage _ deps) = deps--fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage-fromPrunedPackage (PrunedPackage elab _) = elab---- | Set the build targets based on the user targets (but not rev deps yet).--- This is required before we can prune anything.----setRootTargets :: TargetAction-               -> Map UnitId [ComponentTarget]-               -> [ElaboratedPlanPackage]-               -> [ElaboratedPlanPackage]-setRootTargets targetAction perPkgTargetsMap =-    assert (not (Map.null perPkgTargetsMap)) $-    assert (all (not . null) (Map.elems perPkgTargetsMap)) $--    map (mapConfiguredPackage setElabBuildTargets)-  where-    -- Set the targets we'll build for this package/component. This is just-    -- based on the root targets from the user, not targets implied by reverse-    -- dependencies. Those comes in the second pass once we know the rev deps.-    ---    setElabBuildTargets elab =-      case (Map.lookup (installedUnitId elab) perPkgTargetsMap,-            targetAction) of-        (Nothing, _)                      -> elab-        (Just tgts,  TargetActionConfigure) -> elab { elabConfigureTargets = tgts }-        (Just tgts,  TargetActionBuild)   -> elab { elabBuildTargets = tgts }-        (Just tgts,  TargetActionTest)    -> elab { elabTestTargets  = tgts }-        (Just tgts,  TargetActionBench)   -> elab { elabBenchTargets  = tgts }-        (Just [tgt], TargetActionRepl)    -> elab { elabReplTarget = Just tgt-                                                  , elabBuildHaddocks = False }-        (Just tgts,  TargetActionHaddock) ->-          foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts-                                            , elabBuildHaddocks = True }) tgts-        (Just _,     TargetActionRepl)    ->-          error "pruneInstallPlanToTargets: multiple repl targets"--    setElabHaddockTargets tgt elab-      | isTestComponentTarget tgt       = elab { elabHaddockTestSuites  = True }-      | isBenchComponentTarget tgt      = elab { elabHaddockBenchmarks  = True }-      | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True }-      | isExeComponentTarget tgt        = elab { elabHaddockExecutables = True }-      | isSubLibComponentTarget tgt     = elab { elabHaddockInternal    = True }-      | otherwise                       = elab---- | Assuming we have previously set the root build targets (i.e. the user--- targets but not rev deps yet), the first pruning pass does two things:------ * A first go at determining which optional stanzas (testsuites, benchmarks)---   are needed. We have a second go in the next pass.--- * Take the dependency closure using pruned dependencies. We prune deps that---   are used only by unneeded optional stanzas. These pruned deps are only---   used for the dependency closure and are not persisted in this pass.----pruneInstallPlanPass1 :: [ElaboratedPlanPackage]-                      -> [ElaboratedPlanPackage]-pruneInstallPlanPass1 pkgs =-    map (mapConfiguredPackage fromPrunedPackage)-        (fromMaybe [] $ Graph.closure graph roots)-  where-    pkgs' = map (mapConfiguredPackage prune) pkgs-    graph = Graph.fromDistinctList pkgs'-    roots = mapMaybe find_root pkgs'--    prune elab = PrunedPackage elab' (pruneOptionalDependencies elab')-      where elab' =-                setDocumentation-              $ addOptionalStanzas elab--    find_root (InstallPlan.Configured (PrunedPackage elab _)) =-        if not $ and [ null (elabConfigureTargets elab)-                     , null (elabBuildTargets elab)-                     , null (elabTestTargets elab)-                     , null (elabBenchTargets elab)-                     , isNothing (elabReplTarget elab)-                     , null (elabHaddockTargets elab)-                     ]-            then Just (installedUnitId elab)-            else Nothing-    find_root _ = Nothing--    -- Note [Sticky enabled testsuites]-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    -- The testsuite and benchmark targets are somewhat special in that we need-    -- to configure the packages with them enabled, and we need to do that even-    -- if we only want to build one of several testsuites.-    ---    -- There are two cases in which we will enable the testsuites (or-    -- benchmarks): if one of the targets is a testsuite, or if all of the-    -- testsuite dependencies are already cached in the store. The rationale-    -- for the latter is to minimise how often we have to reconfigure due to-    -- the particular targets we choose to build. Otherwise choosing to build-    -- a testsuite target, and then later choosing to build an exe target-    -- would involve unnecessarily reconfiguring the package with testsuites-    -- disabled. Technically this introduces a little bit of stateful-    -- behaviour to make this "sticky", but it should be benign.--    -- Decide whether or not to enable testsuites and benchmarks.-    -- See [Sticky enabled testsuites]-    addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage-    addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =-        elab {-            elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas })-        }-      where-        stanzas :: Set OptionalStanza-               -- By default, we enabled all stanzas requested by the user,-               -- as per elabStanzasRequested, done in-               -- 'elaborateSolverToPackage'-        stanzas = pkgStanzasEnabled pkg-               -- optionalStanzasRequiredByTargets has to be done at-               -- prune-time because it depends on 'elabTestTargets'-               -- et al, which is done by 'setRootTargets' at the-               -- beginning of pruning.-               <> optionalStanzasRequiredByTargets elab-               -- optionalStanzasWithDepsAvailable has to be done at-               -- prune-time because it depends on what packages are-               -- installed, which is not known until after improvement-               -- (pruning is done after improvement)-               <> optionalStanzasWithDepsAvailable availablePkgs elab pkg-    addOptionalStanzas elab = elab--    setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage-    setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } =-      elab {-        elabBuildHaddocks =-            elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab-      }--      where-        documentationEnabled c =-          case c of-            CD.ComponentLib      -> const True-            CD.ComponentSubLib _ -> elabHaddockInternal-            CD.ComponentFLib _   -> elabHaddockForeignLibs-            CD.ComponentExe _    -> elabHaddockExecutables-            CD.ComponentTest _   -> elabHaddockTestSuites-            CD.ComponentBench _  -> elabHaddockBenchmarks-            CD.ComponentSetup    -> const False--    setDocumentation elab = elab--    -- Calculate package dependencies but cut out those needed only by-    -- optional stanzas that we've determined we will not enable.-    -- These pruned deps are not persisted in this pass since they're based on-    -- the optional stanzas and we'll make further tweaks to the optional-    -- stanzas in the next pass.-    ---    pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId]-    pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ }-        = InstallPlan.depends elab -- no pruning-    pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg }-        = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)-      where-        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas-        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas-        keepNeeded _                     _ = True-        stanzas = pkgStanzasEnabled pkg--    optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage-                                     -> Set OptionalStanza-    optionalStanzasRequiredByTargets pkg =-      Set.fromList-        [ stanza-        | ComponentTarget cname _ <- elabBuildTargets pkg-                                  ++ elabTestTargets pkg-                                  ++ elabBenchTargets pkg-                                  ++ maybeToList (elabReplTarget pkg)-                                  ++ elabHaddockTargets pkg-        , stanza <- maybeToList $-                    componentOptionalStanza $-                    CD.componentNameToComponent cname-        ]--    availablePkgs =-      Set.fromList-        [ installedUnitId pkg-        | InstallPlan.PreExisting pkg <- pkgs ]---- | Given a set of already installed packages @availablePkgs@,--- determine the set of available optional stanzas from @pkg@--- which have all of their dependencies already installed.  This is used--- to implement "sticky" testsuites, where once we have installed--- all of the deps needed for the test suite, we go ahead and--- enable it always.-optionalStanzasWithDepsAvailable :: Set UnitId-                                 -> ElaboratedConfiguredPackage-                                 -> ElaboratedPackage-                                 -> Set OptionalStanza-optionalStanzasWithDepsAvailable availablePkgs elab pkg =-    Set.fromList-      [ stanza-      | stanza <- Set.toList (elabStanzasAvailable elab)-      , let deps :: [UnitId]-            deps = CD.select (optionalStanzaDeps stanza)-                             -- TODO: probably need to select other-                             -- dep types too eventually-                             (pkgOrderDependencies pkg)-      , all (`Set.member` availablePkgs) deps-      ]-  where-    optionalStanzaDeps TestStanzas  (CD.ComponentTest  _) = True-    optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True-    optionalStanzaDeps _            _                     = False----- The second pass does three things:------ * A second go at deciding which optional stanzas to enable.--- * Prune the dependencies based on the final choice of optional stanzas.--- * Extend the targets within each package to build, now we know the reverse---   dependencies, ie we know which libs are needed as deps by other packages.------ Achieving sticky behaviour with enabling\/disabling optional stanzas is--- tricky. The first approximation was handled by the first pass above, but--- it's not quite enough. That pass will enable stanzas if all of the deps--- of the optional stanza are already installed /in the store/. That's important--- but it does not account for dependencies that get built inplace as part of--- the project. We cannot take those inplace build deps into account in the--- pruning pass however because we don't yet know which ones we're going to--- build. Once we do know, we can have another go and enable stanzas that have--- all their deps available. Now we can consider all packages in the pruned--- plan to be available, including ones we already decided to build from--- source.------ Deciding which targets to build depends on knowing which packages have--- reverse dependencies (ie are needed). This requires the result of first--- pass, which is another reason we have to split it into two passes.------ Note that just because we might enable testsuites or benchmarks (in the--- first or second pass) doesn't mean that we build all (or even any) of them.--- That depends on which targets we picked in the first pass.----pruneInstallPlanPass2 :: [ElaboratedPlanPackage]-                      -> [ElaboratedPlanPackage]-pruneInstallPlanPass2 pkgs =-    map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs-  where-    setStanzasDepsAndTargets elab =-        elab {-          elabBuildTargets = ordNub-                           $ elabBuildTargets elab-                          ++ libTargetsRequiredForRevDeps-                          ++ exeTargetsRequiredForRevDeps,-          elabPkgOrComp =-            case elabPkgOrComp elab of-              ElabPackage pkg ->-                let stanzas = pkgStanzasEnabled pkg-                           <> optionalStanzasWithDepsAvailable availablePkgs elab pkg-                    keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `Set.member` stanzas-                    keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas-                    keepNeeded _                     _ = True-                in ElabPackage $ pkg {-                  pkgStanzasEnabled = stanzas,-                  pkgLibDependencies   = CD.filterDeps keepNeeded (pkgLibDependencies pkg),-                  pkgExeDependencies   = CD.filterDeps keepNeeded (pkgExeDependencies pkg),-                  pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg)-                }-              r@(ElabComponent _) -> r-        }-      where-        libTargetsRequiredForRevDeps =-          [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent-          | installedUnitId elab `Set.member` hasReverseLibDeps-          ]-        exeTargetsRequiredForRevDeps =-          -- TODO: allow requesting executable with different name-          -- than package name-          [ ComponentTarget (Cabal.CExeName-                             $ packageNameToUnqualComponentName-                             $ packageName $ elabPkgSourceId elab)-                            WholeComponent-          | installedUnitId elab `Set.member` hasReverseExeDeps-          ]---    availablePkgs :: Set UnitId-    availablePkgs = Set.fromList (map installedUnitId pkgs)--    hasReverseLibDeps :: Set UnitId-    hasReverseLibDeps =-      Set.fromList [ depid-                   | InstallPlan.Configured pkg <- pkgs-                   , depid <- elabOrderLibDependencies pkg ]--    hasReverseExeDeps :: Set UnitId-    hasReverseExeDeps =-      Set.fromList [ depid-                   | InstallPlan.Configured pkg <- pkgs-                   , depid <- elabOrderExeDependencies pkg ]--mapConfiguredPackage :: (srcpkg -> srcpkg')-                     -> InstallPlan.GenericPlanPackage ipkg srcpkg-                     -> InstallPlan.GenericPlanPackage ipkg srcpkg'-mapConfiguredPackage f (InstallPlan.Configured pkg) =-  InstallPlan.Configured (f pkg)-mapConfiguredPackage f (InstallPlan.Installed pkg) =-  InstallPlan.Installed (f pkg)-mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =-  InstallPlan.PreExisting pkg----------------------------------------- Support for --only-dependencies------- | Try to remove the given targets from the install plan.------ This is not always possible.----pruneInstallPlanToDependencies :: Set UnitId-                               -> ElaboratedInstallPlan-                               -> Either CannotPruneDependencies-                                         ElaboratedInstallPlan-pruneInstallPlanToDependencies pkgTargets installPlan =-    assert (all (isJust . InstallPlan.lookup installPlan)-                (Set.toList pkgTargets)) $--    fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))-  . checkBrokenDeps-  . Graph.fromDistinctList-  . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)-  . InstallPlan.toList-  $ installPlan-    where-      -- Our strategy is to remove the packages we don't want and then check-      -- if the remaining graph is broken or not, ie any packages with dangling-      -- dependencies. If there are then we cannot prune the given targets.-      checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage-                      -> Either CannotPruneDependencies-                                (Graph.Graph ElaboratedPlanPackage)-      checkBrokenDeps graph =-        case Graph.broken graph of-          []             -> Right graph-          brokenPackages ->-            Left $ CannotPruneDependencies-             [ (pkg, missingDeps)-             | (pkg, missingDepIds) <- brokenPackages-             , let missingDeps = mapMaybe lookupDep missingDepIds-             ]-            where-              -- lookup in the original unpruned graph-              lookupDep = InstallPlan.lookup installPlan---- | It is not always possible to prune to only the dependencies of a set of--- targets. It may be the case that removing a package leaves something else--- that still needed the pruned package.------ This lists all the packages that would be broken, and their dependencies--- that would be missing if we did prune.----newtype CannotPruneDependencies =-        CannotPruneDependencies [(ElaboratedPlanPackage,-                                  [ElaboratedPlanPackage])]-  deriving (Show)--------------------------------- Setup.hs script policy------- Handling for Setup.hs scripts is a bit tricky, part of it lives in the--- solver phase, and part in the elaboration phase. We keep the helper--- functions for both phases together here so at least you can see all of it--- in one place.------ There are four major cases for Setup.hs handling:------  1. @build-type@ Custom with a @custom-setup@ section---  2. @build-type@ Custom without a @custom-setup@ section---  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@---  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@------ It's also worth noting that packages specifying @cabal-version: >= 1.23@--- or later that have @build-type@ Custom will always have a @custom-setup@--- section. Therefore in case 2, the specified @cabal-version@ will always be--- less than 1.23.------ In cases 1 and 2 we obviously have to build an external Setup.hs script,--- while in case 4 we can use the internal library API.------ TODO:In case 3 we should fail. We don't know how to talk to--- newer ./Setup.hs------ data SetupScriptStyle = ...  -- see ProjectPlanning.Types---- | Work out the 'SetupScriptStyle' given the package description.----packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle-packageSetupScriptStyle pkg-  | buildType == PD.Custom-  , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza-  , not (PD.defaultSetupDepends setupbi)  -- but not one we added internally-  = SetupCustomExplicitDeps--  | buildType == PD.Custom-  , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as-  , PD.defaultSetupDepends setupbi        -- the solver fills in the deps-  = SetupCustomImplicitDeps--  | buildType == PD.Custom-  , Nothing <- PD.setupBuildInfo pkg      -- we get this case pre-solver-  = SetupCustomImplicitDeps--  -- here we should fail.-  | PD.specVersion pkg > cabalSpecLatest  -- one cabal-install is built against-  = SetupNonCustomExternalLib--  | otherwise-  = SetupNonCustomInternalLib-  where-    buildType = PD.buildType pkg----- | Part of our Setup.hs handling policy is implemented by getting the solver--- to work out setup dependencies for packages. The solver already handles--- packages that explicitly specify setup dependencies, but we can also tell--- the solver to treat other packages as if they had setup dependencies.--- That's what this function does, it gets called by the solver for all--- packages that don't already have setup dependencies.------ The dependencies we want to add is different for each 'SetupScriptStyle'.------ Note that adding default deps means these deps are actually /added/ to the--- packages that we get out of the solver in the 'SolverInstallPlan'. Making--- implicit setup deps explicit is a problem in the post-solver stages because--- we still need to distinguish the case of explicit and implict setup deps.--- See 'rememberImplicitSetupDeps'.------ Note in addition to adding default setup deps, we also use--- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require--- @Cabal >= 1.20@ for Setup scripts.----defaultSetupDeps :: Compiler -> Platform-                 -> PD.PackageDescription-                 -> Maybe [Dependency]-defaultSetupDeps compiler platform pkg =-    case packageSetupScriptStyle pkg of--      -- For packages with build type custom that do not specify explicit-      -- setup dependencies, we add a dependency on Cabal and a number-      -- of other packages.-      SetupCustomImplicitDeps ->-        Just $-        [ Dependency depPkgname anyVersion mainLibSet-        | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++-        [ Dependency cabalPkgname cabalConstraint mainLibSet-        | packageName pkg /= cabalPkgname ]-        where-          -- The Cabal dep is slightly special:-          -- * We omit the dep for the Cabal lib itself, since it bootstraps.-          -- * We constrain it to be < 1.25-          ---          -- Note: we also add a global constraint to require Cabal >= 1.20-          -- for Setup scripts (see use addSetupCabalMinVersionConstraint).-          ---          cabalConstraint   = orLaterVersion (csvToVersion (PD.specVersion pkg))-                                `intersectVersionRanges`-                              earlierVersion cabalCompatMaxVer-          -- The idea here is that at some point we will make significant-          -- breaking changes to the Cabal API that Setup.hs scripts use.-          -- So for old custom Setup scripts that do not specify explicit-          -- constraints, we constrain them to use a compatible Cabal version.-          cabalCompatMaxVer = mkVersion [1,25]--      -- For other build types (like Simple) if we still need to compile an-      -- external Setup.hs, it'll be one of the simple ones that only depends-      -- on Cabal and base.-      SetupNonCustomExternalLib ->-        Just [ Dependency cabalPkgname cabalConstraint mainLibSet-             , Dependency basePkgname  anyVersion mainLibSet]-        where-          cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg))--      -- The internal setup wrapper method has no deps at all.-      SetupNonCustomInternalLib -> Just []--      -- This case gets ruled out by the caller, planPackages, see the note-      -- above in the SetupCustomImplicitDeps case.-      SetupCustomExplicitDeps ->-        error $ "defaultSetupDeps: called for a package with explicit "-             ++ "setup deps: " ++ prettyShow (packageId pkg)-  where-    -- we require one less-    ---    -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5]-    csvToVersion :: CabalSpecVersion -> Version-    csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion---- | Work out which version of the Cabal we will be using to talk to the--- Setup.hs interface for this package.------ This depends somewhat on the 'SetupScriptStyle' but most cases are a result--- of what the solver picked for us, based on the explicit setup deps or the--- ones added implicitly by 'defaultSetupDeps'.----packageSetupScriptSpecVersion :: SetupScriptStyle-                              -> PD.PackageDescription-                              -> Graph.Graph NonSetupLibDepSolverPlanPackage-                              -> ComponentDeps [SolverId]-                              -> Version---- We're going to be using the internal Cabal library, so the spec version of--- that is simply the version of the Cabal library that cabal-install has been--- built with.-packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ =-    cabalVersion---- If we happen to be building the Cabal lib itself then because that--- bootstraps itself then we use the version of the lib we're building.-packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _-  | packageName pkg == cabalPkgname-  = packageVersion pkg---- In all other cases we have a look at what version of the Cabal lib the--- solver picked. Or if it didn't depend on Cabal at all (which is very rare)--- then we look at the .cabal file to see what spec version it declares.-packageSetupScriptSpecVersion _ pkg libDepGraph deps =-    case find ((cabalPkgname ==) . packageName) setupLibDeps of-      Just dep -> packageVersion dep-      Nothing  -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg))-  where-    setupLibDeps = map packageId $ fromMaybe [] $-                   Graph.closure libDepGraph (CD.setupDeps deps)---cabalPkgname, basePkgname :: PackageName-cabalPkgname = mkPackageName "Cabal"-basePkgname  = mkPackageName "base"---legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName]-legacyCustomSetupPkgs compiler (Platform _ os) =-    map mkPackageName $-        [ "array", "base", "binary", "bytestring", "containers"-        , "deepseq", "directory", "filepath", "pretty"-        , "process", "time", "transformers" ]-     ++ [ "Win32" | os == Windows ]-     ++ [ "unix"  | os /= Windows ]-     ++ [ "ghc-prim"         | isGHC ]-     ++ [ "template-haskell" | isGHC ]-     ++ [ "old-time" | notGHC710 ]-  where-    isGHC = compilerCompatFlavor GHC compiler-    notGHC710 = case compilerCompatVersion GHC compiler of-        Nothing -> False-        Just v  -> v <= mkVersion [7,9]---- The other aspects of our Setup.hs policy lives here where we decide on--- the 'SetupScriptOptions'.------ Our current policy for the 'SetupCustomImplicitDeps' case is that we--- try to make the implicit deps cover everything, and we don't allow the--- compiler to pick up other deps. This may or may not be sustainable, and--- we might have to allow the deps to be non-exclusive, but that itself would--- be tricky since we would have to allow the Setup access to all the packages--- in the store and local dbs.--setupHsScriptOptions :: ElaboratedReadyPackage-                     -> ElaboratedInstallPlan-                     -> ElaboratedSharedConfig-                     -> DistDirLayout-                     -> FilePath-                     -> FilePath-                     -> Bool-                     -> Lock-                     -> SetupScriptOptions--- TODO: Fix this so custom is a separate component.  Custom can ALWAYS--- be a separate component!!!-setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..})-                     plan ElaboratedSharedConfig{..} distdir srcdir builddir-                     isParallelBuild cacheLock =-    SetupScriptOptions {-      useCabalVersion          = thisVersion elabSetupScriptCliVersion,-      useCabalSpecVersion      = Just elabSetupScriptCliVersion,-      useCompiler              = Just pkgConfigCompiler,-      usePlatform              = Just pkgConfigPlatform,-      usePackageDB             = elabSetupPackageDBStack,-      usePackageIndex          = Nothing,-      useDependencies          = [ (uid, srcid)-                                 | ConfiguredId srcid (Just (CLibName LMainLibName)) uid-                                 <- elabSetupDependencies elab ],-      useDependenciesExclusive = True,-      useVersionMacros         = elabSetupScriptStyle == SetupCustomExplicitDeps,-      useProgramDb             = pkgConfigCompilerProgs,-      useDistPref              = builddir,-      useLoggingHandle         = Nothing, -- this gets set later-      useWorkingDir            = Just srcdir,-      useExtraPathEnv          = elabExeDependencyPaths elab,-      useExtraEnvOverrides     = dataDirsEnvironmentForPlan distdir plan,-      useWin32CleanHack        = False,   --TODO: [required eventually]-      forceExternalSetupMethod = isParallelBuild,-      setupCacheLock           = Just cacheLock,-      isInteractive            = False-    }----- | To be used for the input for elaborateInstallPlan.------ TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure.----userInstallDirTemplates :: Compiler-                        -> IO InstallDirs.InstallDirTemplates-userInstallDirTemplates compiler = do-    InstallDirs.defaultInstallDirs-                  (compilerFlavor compiler)-                  True  -- user install-                  False -- unused--storePackageInstallDirs :: StoreDirLayout-                        -> CompilerId-                        -> InstalledPackageId-                        -> InstallDirs.InstallDirs FilePath-storePackageInstallDirs storeDirLayout compid ipkgid =-  storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid--storePackageInstallDirs' :: StoreDirLayout-                         -> CompilerId-                         -> UnitId-                         -> InstallDirs.InstallDirs FilePath-storePackageInstallDirs' StoreDirLayout{ storePackageDirectory-                                       , storeDirectory }-                         compid unitid =-    InstallDirs.InstallDirs {..}-  where-    store        = storeDirectory compid-    prefix       = storePackageDirectory compid unitid-    bindir       = prefix </> "bin"-    libdir       = prefix </> "lib"-    libsubdir    = ""-    -- Note: on macOS, we place libraries into-    --       @store/lib@ to work around the load-    --       command size limit of macOSs mach-o linker.-    --       See also @PackageHash.hashedInstalledPackageIdVeryShort@-    dynlibdir    | buildOS == OSX = store </> "lib"-                 | otherwise      = libdir-    flibdir      = libdir-    libexecdir   = prefix </> "libexec"-    libexecsubdir= ""-    includedir   = libdir </> "include"-    datadir      = prefix </> "share"-    datasubdir   = ""-    docdir       = datadir </> "doc"-    mandir       = datadir </> "man"-    htmldir      = docdir  </> "html"-    haddockdir   = htmldir-    sysconfdir   = prefix </> "etc"----computeInstallDirs :: StoreDirLayout-                   -> InstallDirs.InstallDirTemplates-                   -> ElaboratedSharedConfig-                   -> ElaboratedConfiguredPackage-                   -> InstallDirs.InstallDirs FilePath-computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab-  | elabBuildStyle elab == BuildInplaceOnly-  -- use the ordinary default install dirs-  = (InstallDirs.absoluteInstallDirs-       (elabPkgSourceId elab)-       (elabUnitId elab)-       (compilerInfo (pkgConfigCompiler elaboratedShared))-       InstallDirs.NoCopyDest-       (pkgConfigPlatform elaboratedShared)-       defaultInstallDirs) {--      -- absoluteInstallDirs sets these as 'undefined' but we have-      -- to use them as "Setup.hs configure" args-      InstallDirs.libsubdir  = "",-      InstallDirs.libexecsubdir  = "",-      InstallDirs.datasubdir = ""-    }--  | otherwise-  -- use special simplified install dirs-  = storePackageInstallDirs'-      storeDirLayout-      (compilerId (pkgConfigCompiler elaboratedShared))-      (elabUnitId elab)-----TODO: [code cleanup] perhaps reorder this code--- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,--- make the various Setup.hs {configure,build,copy} flags---setupHsConfigureFlags :: ElaboratedReadyPackage-                      -> ElaboratedSharedConfig-                      -> Verbosity-                      -> FilePath-                      -> Cabal.ConfigFlags-setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..})-                      sharedConfig@ElaboratedSharedConfig{..}-                      verbosity builddir =-    sanityCheckElaboratedConfiguredPackage sharedConfig elab-        (Cabal.ConfigFlags {..})-  where-    configArgs                = mempty -- unused, passed via args-    configDistPref            = toFlag builddir-    configCabalFilePath       = mempty-    configVerbosity           = toFlag verbosity--    configInstantiateWith     = Map.toList elabInstantiatedWith--    configDeterministic       = mempty -- doesn't matter, configIPID/configCID overridese-    configIPID                = case elabPkgOrComp of-                                  ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg))-                                  ElabComponent _ -> mempty-    configCID                 = case elabPkgOrComp of-                                  ElabPackage _ -> mempty-                                  ElabComponent _ -> toFlag elabComponentId--    configProgramPaths        = Map.toList elabProgramPaths-    configProgramArgs-        | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True-          -- workaround for <https://github.com/haskell/cabal/issues/4010>-          ---          -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.-          -- custom Setup.hs scripts calling out to GHC even when going via-          -- @runProgram ghcProgram@, as e.g. happy does in its-          -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>-          -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)-          ---          -- So for now, let's pass the rather harmless and idempotent-          -- `-hide-all-packages` flag to all invocations (which has-          -- the benefit that every GHC invocation starts with a-          -- conistently well-defined clean slate) until we find a-          -- better way.-                              = Map.toList $-                                Map.insertWith (++) "ghc" ["-hide-all-packages"]-                                               elabProgramArgs-        | otherwise           = Map.toList elabProgramArgs-    configProgramPathExtra    = toNubList elabProgramPathExtra-    configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)-    configHcPath              = mempty -- we use configProgramPaths instead-    configHcPkg               = mempty -- we use configProgramPaths instead--    configVanillaLib          = toFlag elabVanillaLib-    configSharedLib           = toFlag elabSharedLib-    configStaticLib           = toFlag elabStaticLib--    configDynExe              = toFlag elabDynExe-    configFullyStaticExe      = toFlag elabFullyStaticExe-    configGHCiLib             = toFlag elabGHCiLib-    configProfExe             = mempty-    configProfLib             = toFlag elabProfLib-    configProf                = toFlag elabProfExe--    -- configProfDetail is for exe+lib, but overridden by configProfLibDetail-    -- so we specify both so we can specify independently-    configProfDetail          = toFlag elabProfExeDetail-    configProfLibDetail       = toFlag elabProfLibDetail--    configCoverage            = toFlag elabCoverage-    configLibCoverage         = mempty--    configOptimization        = toFlag elabOptimization-    configSplitSections       = toFlag elabSplitSections-    configSplitObjs           = toFlag elabSplitObjs-    configStripExes           = toFlag elabStripExes-    configStripLibs           = toFlag elabStripLibs-    configDebugInfo           = toFlag elabDebugInfo--    configConfigurationsFlags = elabFlagAssignment-    configConfigureArgs       = elabConfigureScriptArgs-    configExtraLibDirs        = elabExtraLibDirs-    configExtraFrameworkDirs  = elabExtraFrameworkDirs-    configExtraIncludeDirs    = elabExtraIncludeDirs-    configProgPrefix          = maybe mempty toFlag elabProgPrefix-    configProgSuffix          = maybe mempty toFlag elabProgSuffix--    configInstallDirs         = fmap (toFlag . InstallDirs.toPathTemplate)-                                     elabInstallDirs--    -- we only use configDependencies, unless we're talking to an old Cabal-    -- in which case we use configConstraints-    -- NB: This does NOT use InstallPlan.depends, which includes executable-    -- dependencies which should NOT be fed in here (also you don't have-    -- enough info anyway)-    configDependencies        = [ GivenComponent-                                    (packageName srcid)-                                    ln-                                    cid-                                | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab-                                , let ln = case mb_cn-                                           of Just (CLibName lname) -> lname-                                              Just _ -> error "non-library dependency"-                                              Nothing -> LMainLibName-                                ]-    configConstraints         =-        case elabPkgOrComp of-            ElabPackage _ ->-                [ thisPackageVersionConstraint srcid-                | ConfiguredId srcid _ _uid <- elabLibDependencies elab ]-            ElabComponent _ -> []---    -- explicitly clear, then our package db stack-    -- TODO: [required eventually] have to do this differently for older Cabal versions-    configPackageDBs          = Nothing : map Just elabBuildPackageDBStack--    configTests               = case elabPkgOrComp of-                                    ElabPackage pkg -> toFlag (TestStanzas  `Set.member` pkgStanzasEnabled pkg)-                                    ElabComponent _ -> mempty-    configBenchmarks          = case elabPkgOrComp of-                                    ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg)-                                    ElabComponent _ -> mempty--    configExactConfiguration  = toFlag True-    configFlagError           = mempty --TODO: [research required] appears not to be implemented-    configRelocatable         = mempty --TODO: [research required] ???-    configScratchDir          = mempty -- never use-    configUserInstall         = mempty -- don't rely on defaults-    configPrograms_           = mempty -- never use, shouldn't exist-    configUseResponseFiles    = mempty-    configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler--setupHsConfigureArgs :: ElaboratedConfiguredPackage-                     -> [String]-setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = []-setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) =-    [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)]-  where-    cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup")-                      (compComponentName comp)--setupHsBuildFlags :: ElaboratedConfiguredPackage-                  -> ElaboratedSharedConfig-                  -> Verbosity-                  -> FilePath-                  -> Cabal.BuildFlags-setupHsBuildFlags _ _ verbosity builddir =-    Cabal.BuildFlags {-      buildProgramPaths = mempty, --unused, set at configure time-      buildProgramArgs  = mempty, --unused, set at configure time-      buildVerbosity    = toFlag verbosity,-      buildDistPref     = toFlag builddir,-      buildNumJobs      = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),-      buildArgs         = mempty, -- unused, passed via args not flags-      buildCabalFilePath= mempty-    }---setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]-setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ })-    -- Fix for #3335, don't pass build arguments if it's not supported-    | elabSetupScriptCliVersion elab >= mkVersion [1,17]-    = map (showComponentTarget (packageId elab)) (elabBuildTargets elab)-    | otherwise-    = []-setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ })-    = []---setupHsTestFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.TestFlags-setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags-    { testDistPref    = toFlag builddir-    , testVerbosity   = toFlag verbosity-    , testMachineLog  = maybe mempty toFlag elabTestMachineLog-    , testHumanLog    = maybe mempty toFlag elabTestHumanLog-    , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails-    , testKeepTix     = toFlag elabTestKeepTix-    , testWrapper     = maybe mempty toFlag elabTestWrapper-    , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites-    , testOptions     = elabTestTestOptions-    }--setupHsTestArgs :: ElaboratedConfiguredPackage -> [String]--- TODO: Does the issue #3335 affects test as well-setupHsTestArgs elab =-    mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab)---setupHsBenchFlags :: ElaboratedConfiguredPackage-                  -> ElaboratedSharedConfig-                  -> Verbosity-                  -> FilePath-                  -> Cabal.BenchmarkFlags-setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags-    { benchmarkDistPref  = toFlag builddir-    , benchmarkVerbosity = toFlag verbosity-    , benchmarkOptions   = elabBenchmarkOptions-    }--setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String]-setupHsBenchArgs elab =-    mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab)---setupHsReplFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.ReplFlags-setupHsReplFlags _ sharedConfig verbosity builddir =-    Cabal.ReplFlags {-      replProgramPaths = mempty, --unused, set at configure time-      replProgramArgs  = mempty, --unused, set at configure time-      replVerbosity    = toFlag verbosity,-      replDistPref     = toFlag builddir,-      replReload       = mempty, --only used as callback from repl-      replReplOptions  = pkgConfigReplOptions sharedConfig       --runtime override for repl flags-    }---setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]-setupHsReplArgs elab =-    maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab)-    --TODO: should be able to give multiple modules in one component---setupHsCopyFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> FilePath-                 -> Cabal.CopyFlags-setupHsCopyFlags _ _ verbosity builddir destdir =-    Cabal.CopyFlags {-      copyArgs      = [], -- TODO: could use this to only copy what we enabled-      copyDest      = toFlag (InstallDirs.CopyTo destdir),-      copyDistPref  = toFlag builddir,-      copyVerbosity = toFlag verbosity,-      copyCabalFilePath = mempty-    }--setupHsRegisterFlags :: ElaboratedConfiguredPackage-                     -> ElaboratedSharedConfig-                     -> Verbosity-                     -> FilePath-                     -> FilePath-                     -> Cabal.RegisterFlags-setupHsRegisterFlags ElaboratedConfiguredPackage{..} _-                     verbosity builddir pkgConfFile =-    Cabal.RegisterFlags {-      regPackageDB   = mempty,  -- misfeature-      regGenScript   = mempty,  -- never use-      regGenPkgConf  = toFlag (Just pkgConfFile),-      regInPlace     = case elabBuildStyle of-                         BuildInplaceOnly -> toFlag True-                         _                -> toFlag False,-      regPrintId     = mempty,  -- never use-      regDistPref    = toFlag builddir,-      regArgs        = [],-      regVerbosity   = toFlag verbosity,-      regCabalFilePath = mempty-    }--setupHsHaddockFlags :: ElaboratedConfiguredPackage-                    -> ElaboratedSharedConfig-                    -> Verbosity-                    -> FilePath-                    -> Cabal.HaddockFlags-setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir =-    Cabal.HaddockFlags {-      haddockProgramPaths  = mempty, --unused, set at configure time-      haddockProgramArgs   = mempty, --unused, set at configure time-      haddockHoogle        = toFlag elabHaddockHoogle,-      haddockHtml          = toFlag elabHaddockHtml,-      haddockHtmlLocation  = maybe mempty toFlag elabHaddockHtmlLocation,-      haddockForHackage    = toFlag elabHaddockForHackage,-      haddockForeignLibs   = toFlag elabHaddockForeignLibs,-      haddockExecutables   = toFlag elabHaddockExecutables,-      haddockTestSuites    = toFlag elabHaddockTestSuites,-      haddockBenchmarks    = toFlag elabHaddockBenchmarks,-      haddockInternal      = toFlag elabHaddockInternal,-      haddockCss           = maybe mempty toFlag elabHaddockCss,-      haddockLinkedSource  = toFlag elabHaddockLinkedSource,-      haddockQuickJump     = toFlag elabHaddockQuickJump,-      haddockHscolourCss   = maybe mempty toFlag elabHaddockHscolourCss,-      haddockContents      = maybe mempty toFlag elabHaddockContents,-      haddockDistPref      = toFlag builddir,-      haddockKeepTempFiles = mempty, --TODO: from build settings-      haddockVerbosity     = toFlag verbosity,-      haddockCabalFilePath = mempty,-      haddockArgs          = mempty-    }--setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String]--- TODO: Does the issue #3335 affects test as well-setupHsHaddockArgs elab =-  map (showComponentTarget (packageId elab)) (elabHaddockTargets elab)--{--setupHsTestFlags :: ElaboratedConfiguredPackage-                 -> ElaboratedSharedConfig-                 -> Verbosity-                 -> FilePath-                 -> Cabal.TestFlags-setupHsTestFlags _ _ verbosity builddir =-    Cabal.TestFlags {-    }--}----------------------------------------------------------------------------------- * Sharing installed packages-------------------------------------------------------------------------------------- Nix style store management for tarball packages------ So here's our strategy:------ We use a per-user nix-style hashed store, but /only/ for tarball packages.--- So that includes packages from hackage repos (and other http and local--- tarballs). For packages in local directories we do not register them into--- the shared store by default, we just build them locally inplace.------ The reason we do it like this is that it's easy to make stable hashes for--- tarball packages, and these packages benefit most from sharing. By contrast--- unpacked dir packages are harder to hash and they tend to change more--- frequently so there's less benefit to sharing them.------ When using the nix store approach we have to run the solver *without*--- looking at the packages installed in the store, just at the source packages--- (plus core\/global installed packages). Then we do a post-processing pass--- to replace configured packages in the plan with pre-existing ones, where--- possible. Where possible of course means where the nix-style package hash--- equals one that's already in the store.------ One extra wrinkle is that unless we know package tarball hashes upfront, we--- will have to download the tarballs to find their hashes. So we have two--- options: delay replacing source with pre-existing installed packages until--- the point during the execution of the install plan where we have the--- tarball, or try to do as much up-front as possible and then check again--- during plan execution. The former isn't great because we would end up--- telling users we're going to re-install loads of packages when in fact we--- would just share them. It'd be better to give as accurate a prediction as--- we can. The latter is better for users, but we do still have to check--- during plan execution because it's important that we don't replace existing--- installed packages even if they have the same package hash, because we--- don't guarantee ABI stability.---- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but--- not replace installed packages with ghc-pkg.--packageHashInputs :: ElaboratedSharedConfig-                  -> ElaboratedConfiguredPackage-                  -> PackageHashInputs-packageHashInputs-    pkgshared-    elab@(ElaboratedConfiguredPackage {-      elabPkgSourceHash = Just srchash-    }) =-    PackageHashInputs {-      pkgHashPkgId       = packageId elab,-      pkgHashComponent   =-        case elabPkgOrComp elab of-          ElabPackage _ -> Nothing-          ElabComponent comp -> Just (compSolverName comp),-      pkgHashSourceHash  = srchash,-      pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab),-      pkgHashDirectDeps  =-        case elabPkgOrComp elab of-          ElabPackage (ElaboratedPackage{..}) ->-            Set.fromList $-             [ confInstId dep-             | dep <- CD.select relevantDeps pkgLibDependencies ] ++-             [ confInstId dep-             | dep <- CD.select relevantDeps pkgExeDependencies ]-          ElabComponent comp ->-            Set.fromList (map confInstId (compLibDependencies comp-                                       ++ compExeDependencies comp)),-      pkgHashOtherConfig = packageHashConfigInputs pkgshared elab-    }-  where-    -- Obviously the main deps are relevant-    relevantDeps CD.ComponentLib       = True-    relevantDeps (CD.ComponentSubLib _) = True-    relevantDeps (CD.ComponentFLib _)   = True-    relevantDeps (CD.ComponentExe _)   = True-    -- Setup deps can affect the Setup.hs behaviour and thus what is built-    relevantDeps  CD.ComponentSetup    = True-    -- However testsuites and benchmarks do not get installed and should not-    -- affect the result, so we do not include them.-    relevantDeps (CD.ComponentTest  _) = False-    relevantDeps (CD.ComponentBench _) = False--packageHashInputs _ pkg =-    error $ "packageHashInputs: only for packages with source hashes. "-         ++ prettyShow (packageId pkg)--packageHashConfigInputs :: ElaboratedSharedConfig-                        -> ElaboratedConfiguredPackage-                        -> PackageHashConfigInputs-packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =-    PackageHashConfigInputs {-      pkgHashCompilerId          = compilerId pkgConfigCompiler,-      pkgHashPlatform            = pkgConfigPlatform,-      pkgHashFlagAssignment      = elabFlagAssignment,-      pkgHashConfigureScriptArgs = elabConfigureScriptArgs,-      pkgHashVanillaLib          = elabVanillaLib,-      pkgHashSharedLib           = elabSharedLib,-      pkgHashDynExe              = elabDynExe,-      pkgHashFullyStaticExe      = elabFullyStaticExe,-      pkgHashGHCiLib             = elabGHCiLib,-      pkgHashProfLib             = elabProfLib,-      pkgHashProfExe             = elabProfExe,-      pkgHashProfLibDetail       = elabProfLibDetail,-      pkgHashProfExeDetail       = elabProfExeDetail,-      pkgHashCoverage            = elabCoverage,-      pkgHashOptimization        = elabOptimization,-      pkgHashSplitSections       = elabSplitSections,-      pkgHashSplitObjs           = elabSplitObjs,-      pkgHashStripLibs           = elabStripLibs,-      pkgHashStripExes           = elabStripExes,-      pkgHashDebugInfo           = elabDebugInfo,-      pkgHashProgramArgs         = elabProgramArgs,-      pkgHashExtraLibDirs        = elabExtraLibDirs,-      pkgHashExtraFrameworkDirs  = elabExtraFrameworkDirs,-      pkgHashExtraIncludeDirs    = elabExtraIncludeDirs,-      pkgHashProgPrefix          = elabProgPrefix,-      pkgHashProgSuffix          = elabProgSuffix,--      pkgHashDocumentation       = elabBuildHaddocks,-      pkgHashHaddockHoogle       = elabHaddockHoogle,-      pkgHashHaddockHtml         = elabHaddockHtml,-      pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation,-      pkgHashHaddockForeignLibs  = elabHaddockForeignLibs,-      pkgHashHaddockExecutables  = elabHaddockExecutables,-      pkgHashHaddockTestSuites   = elabHaddockTestSuites,-      pkgHashHaddockBenchmarks   = elabHaddockBenchmarks,-      pkgHashHaddockInternal     = elabHaddockInternal,-      pkgHashHaddockCss          = elabHaddockCss,-      pkgHashHaddockLinkedSource = elabHaddockLinkedSource,-      pkgHashHaddockQuickJump    = elabHaddockQuickJump,-      pkgHashHaddockContents     = elabHaddockContents-    }-  where-    ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg---- | Given the 'InstalledPackageIndex' for a nix-style package store, and an--- 'ElaboratedInstallPlan', replace configured source packages by installed--- packages from the store whenever they exist.----improveInstallPlanWithInstalledPackages :: Set UnitId-                                        -> ElaboratedInstallPlan-                                        -> ElaboratedInstallPlan-improveInstallPlanWithInstalledPackages installedPkgIdSet =-    InstallPlan.installed canPackageBeImproved-  where-    canPackageBeImproved pkg =-      installedUnitId pkg `Set.member` installedPkgIdSet-    --TODO: sanity checks:-    -- * the installed package must have the expected deps etc-    -- * the installed package must not be broken, valid dep closure--    --TODO: decide what to do if we encounter broken installed packages,-    -- since overwriting is never safe.----- Path construction----------- | The path to the directory that contains a specific executable.--- NB: For inplace NOT InstallPaths.bindir installDirs; for an--- inplace build those values are utter nonsense.  So we--- have to guess where the directory is going to be.--- Fortunately this is "stable" part of Cabal API.--- But the way we get the build directory is A HORRIBLE--- HACK.-binDirectoryFor-  :: DistDirLayout-  -> ElaboratedSharedConfig-  -> ElaboratedConfiguredPackage-  -> FilePath-  -> FilePath-binDirectoryFor layout config package exe = case elabBuildStyle package of-  BuildAndInstall -> installedBinDirectory package-  BuildInplaceOnly -> inplaceBinRoot layout config package </> exe---- package has been built and installed.-installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath-installedBinDirectory = InstallDirs.bindir . elabInstallDirs---- | The path to the @build@ directory for an inplace build.-inplaceBinRoot-  :: DistDirLayout-  -> ElaboratedSharedConfig-  -> ElaboratedConfiguredPackage-  -> FilePath-inplaceBinRoot layout config package-  =  distBuildDirectory layout (elabDistDirParams config package)- </> "build"
− Distribution/Client/ProjectPlanning/Types.hs 
@@ -1,840 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}---- | Types used while planning how to build everything in a project.------ Primarily this is the 'ElaboratedInstallPlan'.----module Distribution.Client.ProjectPlanning.Types (-    SolverInstallPlan,--    -- * Elaborated install plan types-    ElaboratedInstallPlan,-    normaliseConfiguredPackage,-    ElaboratedConfiguredPackage(..),--    elabDistDirParams,-    elabExeDependencyPaths,-    elabLibDependencies,-    elabOrderLibDependencies,-    elabExeDependencies,-    elabOrderExeDependencies,-    elabSetupDependencies,-    elabPkgConfigDependencies,-    elabInplaceDependencyBuildCacheFiles,-    elabRequiresRegistration,-    dataDirsEnvironmentForPlan,--    elabPlanPackageName,-    elabConfiguredName,-    elabComponentName,--    ElaboratedPackageOrComponent(..),-    ElaboratedComponent(..),-    ElaboratedPackage(..),-    pkgOrderDependencies,-    ElaboratedPlanPackage,-    ElaboratedSharedConfig(..),-    ElaboratedReadyPackage,-    BuildStyle(..),-    CabalFileText,--    -- * Build targets-    ComponentTarget(..),-    showComponentTarget,-    showTestComponentTarget,-    showBenchComponentTarget,-    SubComponentTarget(..),--    isSubLibComponentTarget,-    isForeignLibComponentTarget,-    isExeComponentTarget,-    isTestComponentTarget,-    isBenchComponentTarget,--    componentOptionalStanza,--    -- * Setup script-    SetupScriptStyle(..),-  ) where--import           Distribution.Client.Compat.Prelude-import           Prelude ()--import           Distribution.Client.TargetSelector-                   ( SubComponentTarget(..) )-import           Distribution.Client.PackageHash--import           Distribution.Client.Types-import qualified Distribution.Client.InstallPlan as InstallPlan-import           Distribution.Client.InstallPlan-                   ( GenericInstallPlan, GenericPlanPackage(..) )-import           Distribution.Client.SolverInstallPlan-                   ( SolverInstallPlan )-import           Distribution.Client.DistDirLayout--import           Distribution.Backpack-import           Distribution.Backpack.ModuleShape--import           Distribution.Verbosity (normal)-import           Distribution.Types.ComponentRequestedSpec-import           Distribution.Types.PkgconfigVersion-import           Distribution.Types.PackageDescription (PackageDescription(..))-import           Distribution.Package-import           Distribution.System-import qualified Distribution.PackageDescription as Cabal-import           Distribution.InstalledPackageInfo (InstalledPackageInfo)-import           Distribution.Simple.Compiler-import           Distribution.Simple.Build.PathsModule (pkgPathEnvVar)-import qualified Distribution.Simple.BuildTarget as Cabal-import           Distribution.Simple.Program-import           Distribution.ModuleName (ModuleName)-import           Distribution.Simple.LocalBuildInfo-                   ( ComponentName(..), LibraryName(..) )-import qualified Distribution.Simple.InstallDirs as InstallDirs-import           Distribution.Simple.InstallDirs (PathTemplate)-import           Distribution.Simple.Setup (HaddockTarget, TestShowDetails)-import           Distribution.Version--import qualified Distribution.Solver.Types.ComponentDeps as CD-import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Compat.Graph (IsNode(..))-import           Distribution.Simple.Utils (ordNub)--import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Monoid as Mon-import           System.FilePath ((</>))----- | The combination of an elaborated install plan plus a--- 'ElaboratedSharedConfig' contains all the details necessary to be able--- to execute the plan without having to make further policy decisions.------ It does not include dynamic elements such as resources (such as http--- connections).----type ElaboratedInstallPlan-   = GenericInstallPlan InstalledPackageInfo-                        ElaboratedConfiguredPackage--type ElaboratedPlanPackage-   = GenericPlanPackage InstalledPackageInfo-                        ElaboratedConfiguredPackage---- | User-friendly display string for an 'ElaboratedPlanPackage'.-elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String-elabPlanPackageName verbosity (PreExisting ipkg)-    | verbosity <= normal = prettyShow (packageName ipkg)-    | otherwise           = prettyShow (installedUnitId ipkg)-elabPlanPackageName verbosity (Configured elab)-    = elabConfiguredName verbosity elab-elabPlanPackageName verbosity (Installed elab)-    = elabConfiguredName verbosity elab----TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle---      even platform and compiler could be different if we're building things---      like a server + client with ghc + ghcjs-data ElaboratedSharedConfig-   = ElaboratedSharedConfig {--       pkgConfigPlatform      :: Platform,-       pkgConfigCompiler      :: Compiler, --TODO: [code cleanup] replace with CompilerInfo-       -- | The programs that the compiler configured (e.g. for GHC, the progs-       -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are-       -- used.-       pkgConfigCompilerProgs :: ProgramDb,-       pkgConfigReplOptions :: [String]-     }-  deriving (Show, Generic, Typeable)-  --TODO: [code cleanup] no Eq instance--instance Binary ElaboratedSharedConfig-instance Structured ElaboratedSharedConfig--data ElaboratedConfiguredPackage-   = ElaboratedConfiguredPackage {-       -- | The 'UnitId' which uniquely identifies this item in a build plan-       elabUnitId        :: UnitId,--       elabComponentId :: ComponentId,-       elabInstantiatedWith :: Map ModuleName Module,-       elabLinkedInstantiatedWith :: Map ModuleName OpenModule,--       -- | This is true if this is an indefinite package, or this is a-       -- package with no signatures.  (Notably, it's not true for instantiated-       -- packages.)  The motivation for this is if you ask to build-       -- @foo-indef@, this probably means that you want to typecheck-       -- it, NOT that you want to rebuild all of the various-       -- instantiations of it.-       elabIsCanonical :: Bool,--       -- | The 'PackageId' of the originating package-       elabPkgSourceId    :: PackageId,--       -- | Shape of the package/component, for Backpack.-       elabModuleShape    :: ModuleShape,--       -- | A total flag assignment for the package.-       -- TODO: Actually this can be per-component if we drop-       -- all flags that don't affect a component.-       elabFlagAssignment   :: Cabal.FlagAssignment,--       -- | The original default flag assignment, used only for reporting.-       elabFlagDefaults     :: Cabal.FlagAssignment,--       elabPkgDescription :: Cabal.PackageDescription,--       -- | Where the package comes from, e.g. tarball, local dir etc. This-       --   is not the same as where it may be unpacked to for the build.-       elabPkgSourceLocation :: PackageLocation (Maybe FilePath),--       -- | The hash of the source, e.g. the tarball. We don't have this for-       -- local source dir packages.-       elabPkgSourceHash     :: Maybe PackageSourceHash,--       -- | Is this package one of the ones specified by location in the-       -- project file? (As opposed to a dependency, or a named package pulled-       -- in)-       elabLocalToProject         :: Bool,--       -- | Are we going to build and install this package to the store, or are-       -- we going to build it and register it locally.-       elabBuildStyle             :: BuildStyle,--       -- | Another way of phrasing 'pkgStanzasAvailable'.-       elabEnabledSpec      :: ComponentRequestedSpec,--       -- | Which optional stanzas (ie testsuites, benchmarks) can be built.-       -- This means the solver produced a plan that has them available.-       -- This doesn't necessary mean we build them by default.-       elabStanzasAvailable :: Set OptionalStanza,--       -- | Which optional stanzas the user explicitly asked to enable or-       -- to disable. This tells us which ones we build by default, and-       -- helps with error messages when the user asks to build something-       -- they explicitly disabled.-       ---       -- TODO: The 'Bool' here should be refined into an ADT with three-       -- cases: NotRequested, ExplicitlyRequested and-       -- ImplicitlyRequested.  A stanza is explicitly requested if-       -- the user asked, for this *specific* package, that the stanza-       -- be enabled; it's implicitly requested if the user asked for-       -- all global packages to have this stanza enabled.  The-       -- difference between an explicit and implicit request is-       -- error reporting behavior: if a user asks for tests to be-       -- enabled for a specific package that doesn't have any tests,-       -- we should warn them about it, but we shouldn't complain-       -- that a user enabled tests globally, and some local packages-       -- just happen not to have any tests.  (But perhaps we should-       -- warn if ALL local packages don't have any tests.)-       elabStanzasRequested :: Map OptionalStanza Bool,--       elabSetupPackageDBStack    :: PackageDBStack,-       elabBuildPackageDBStack    :: PackageDBStack,-       elabRegisterPackageDBStack :: PackageDBStack,--       elabPkgDescriptionOverride  :: Maybe CabalFileText,--       -- TODO: make per-component variants of these flags-       elabVanillaLib           :: Bool,-       elabSharedLib            :: Bool,-       elabStaticLib            :: Bool,-       elabDynExe               :: Bool,-       elabFullyStaticExe       :: Bool,-       elabGHCiLib              :: Bool,-       elabProfLib              :: Bool,-       elabProfExe              :: Bool,-       elabProfLibDetail        :: ProfDetailLevel,-       elabProfExeDetail        :: ProfDetailLevel,-       elabCoverage             :: Bool,-       elabOptimization         :: OptimisationLevel,-       elabSplitObjs            :: Bool,-       elabSplitSections        :: Bool,-       elabStripLibs            :: Bool,-       elabStripExes            :: Bool,-       elabDebugInfo            :: DebugInfoLevel,--       elabProgramPaths          :: Map String FilePath,-       elabProgramArgs           :: Map String [String],-       elabProgramPathExtra      :: [FilePath],-       elabConfigureScriptArgs   :: [String],-       elabExtraLibDirs          :: [FilePath],-       elabExtraFrameworkDirs    :: [FilePath],-       elabExtraIncludeDirs      :: [FilePath],-       elabProgPrefix            :: Maybe PathTemplate,-       elabProgSuffix            :: Maybe PathTemplate,--       elabInstallDirs           :: InstallDirs.InstallDirs FilePath,--       elabHaddockHoogle         :: Bool,-       elabHaddockHtml           :: Bool,-       elabHaddockHtmlLocation   :: Maybe String,-       elabHaddockForeignLibs    :: Bool,-       elabHaddockForHackage     :: HaddockTarget,-       elabHaddockExecutables    :: Bool,-       elabHaddockTestSuites     :: Bool,-       elabHaddockBenchmarks     :: Bool,-       elabHaddockInternal       :: Bool,-       elabHaddockCss            :: Maybe FilePath,-       elabHaddockLinkedSource   :: Bool,-       elabHaddockQuickJump      :: Bool,-       elabHaddockHscolourCss    :: Maybe FilePath,-       elabHaddockContents       :: Maybe PathTemplate,--       elabTestMachineLog        :: Maybe PathTemplate,-       elabTestHumanLog          :: Maybe PathTemplate,-       elabTestShowDetails       :: Maybe TestShowDetails,-       elabTestKeepTix           :: Bool,-       elabTestWrapper           :: Maybe FilePath,-       elabTestFailWhenNoTestSuites :: Bool,-       elabTestTestOptions       :: [PathTemplate],--       elabBenchmarkOptions      :: [PathTemplate],--       -- Setup.hs related things:--       -- | One of four modes for how we build and interact with the Setup.hs-       -- script, based on whether it's a build-type Custom, with or without-       -- explicit deps and the cabal spec version the .cabal file needs.-       elabSetupScriptStyle      :: SetupScriptStyle,--       -- | The version of the Cabal command line interface that we are using-       -- for this package. This is typically the version of the Cabal lib-       -- that the Setup.hs is built against.-       ---       -- TODO: We might want to turn this into a enum,-       -- yet different enum than 'CabalSpecVersion'.-       elabSetupScriptCliVersion :: Version,--       -- Build time related:-       elabConfigureTargets      :: [ComponentTarget],-       elabBuildTargets          :: [ComponentTarget],-       elabTestTargets           :: [ComponentTarget],-       elabBenchTargets          :: [ComponentTarget],-       elabReplTarget            :: Maybe ComponentTarget,-       elabHaddockTargets        :: [ComponentTarget],--       elabBuildHaddocks         :: Bool,--       --pkgSourceDir ? -- currently passed in later because they can use temp locations-       --pkgBuildDir  ? -- but could in principle still have it here, with optional instr to use temp loc--       -- | Component/package specific information-       elabPkgOrComp :: ElaboratedPackageOrComponent-   }-  deriving (Eq, Show, Generic, Typeable)--normaliseConfiguredPackage :: ElaboratedSharedConfig-                           -> ElaboratedConfiguredPackage-                           -> ElaboratedConfiguredPackage-normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =-    pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) }-  where-    knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs--    pkgDesc :: PackageDescription-    pkgDesc = elabPkgDescription pkg--    removeEmpty :: [String] -> Maybe [String]-    removeEmpty [] = Nothing-    removeEmpty xs = Just xs--    lookupFilter :: String -> [String] -> Maybe [String]-    lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of-        Just p -> programNormaliseArgs p (getVersion p) pkgDesc args-        Nothing -> args--    getVersion :: Program -> Maybe Version-    getVersion p = lookupProgram p knownProgramDb >>= programVersion---- | The package/component contains/is a library and so must be registered-elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool-elabRequiresRegistration elab =-    case elabPkgOrComp elab of-        ElabComponent comp ->-            case compComponentName comp of-                Just cn -> is_lib cn && build_target-                _ -> False-        ElabPackage pkg ->-            -- Tricky! Not only do we have to test if the user selected-            -- a library as a build target, we also have to test if-            -- the library was TRANSITIVELY depended upon, since we will-            -- also require a register in this case.-            ---            -- NB: It would have been far nicer to just unconditionally-            -- register in all cases, but some Custom Setups will fall-            -- over if you try to do that, ESPECIALLY if there actually is-            -- a library but they hadn't built it.-            ---            -- However, as the case of `cpphs-1.20.8` has shown in-            -- #5379, in cases when a monolithic package gets-            -- installed due to its executable components-            -- (i.e. exe:cpphs) into the store we *have* to register-            -- if there's a buildable public library (i.e. lib:cpphs)-            -- that was built and installed into the same store folder-            -- as otherwise this will cause build failures once a-            -- target actually depends on lib:cpphs.-            build_target || (elabBuildStyle elab == BuildAndInstall &&-                             Cabal.hasPublicLib (elabPkgDescription elab))-            -- the next sub-condition below is currently redundant-            -- (see discussion in #5604 for more details), but it's-            -- being kept intentionally here as a safeguard because if-            -- internal libraries ever start working with-            -- non-per-component builds this condition won't be-            -- redundant anymore.-                         || any (depends_on_lib pkg) (elabBuildTargets elab)-  where-    depends_on_lib pkg (ComponentTarget cn _) =-        not (null (CD.select (== CD.componentNameToComponent cn)-                             (pkgDependsOnSelfLib pkg)))-    build_target =-        if not (null (elabBuildTargets elab))-            then any is_lib_target (elabBuildTargets elab)-            -- Empty build targets mean we build /everything/;-            -- that means we have to look more carefully to see-            -- if there is anything to register-            else Cabal.hasLibs (elabPkgDescription elab)-    -- NB: this means we DO NOT reregister if you just built a-    -- single file-    is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn-    is_lib_target _ = False-    is_lib (CLibName _) = True-    is_lib _ = False---- | Construct the environment needed for the data files to work.--- This consists of a separate @*_datadir@ variable for each--- inplace package in the plan.-dataDirsEnvironmentForPlan :: DistDirLayout-                           -> ElaboratedInstallPlan-                           -> [(String, Maybe FilePath)]-dataDirsEnvironmentForPlan distDirLayout = catMaybes-                           . fmap (InstallPlan.foldPlanPackage-                               (const Nothing)-                               (dataDirEnvVarForPackage distDirLayout))-                           . InstallPlan.toList---- | Construct an environment variable that points--- the package's datadir to its correct location.--- This might be:--- * 'Just' the package's source directory plus the data subdirectory---   for inplace packages.--- * 'Nothing' for packages installed in the store (the path was---   already included in the package at install/build time).-dataDirEnvVarForPackage :: DistDirLayout-                        -> ElaboratedConfiguredPackage-                        -> Maybe (String, Maybe FilePath)-dataDirEnvVarForPackage distDirLayout pkg =-  case elabBuildStyle pkg-  of BuildAndInstall -> Nothing-     BuildInplaceOnly -> Just-       ( pkgPathEnvVar (elabPkgDescription pkg) "datadir"-       , Just $ srcPath (elabPkgSourceLocation pkg)-            </> dataDir (elabPkgDescription pkg))-  where-    srcPath (LocalUnpackedPackage path) = path-    srcPath (LocalTarballPackage _path) = unpackedPath-    srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath-    srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath-    srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout-    -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc-    srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error-      "calling dataDirEnvVarForPackage on a not-downloaded repo is an error"-    unpackedPath =-      distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg--instance Package ElaboratedConfiguredPackage where-  packageId = elabPkgSourceId--instance HasConfiguredId ElaboratedConfiguredPackage where-  configuredId elab =-    ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab)--instance HasUnitId ElaboratedConfiguredPackage where-  installedUnitId = elabUnitId--instance IsNode ElaboratedConfiguredPackage where-    type Key ElaboratedConfiguredPackage = UnitId-    nodeKey = elabUnitId-    nodeNeighbors = elabOrderDependencies--instance Binary ElaboratedConfiguredPackage-instance Structured ElaboratedConfiguredPackage--data ElaboratedPackageOrComponent-    = ElabPackage   ElaboratedPackage-    | ElabComponent ElaboratedComponent-  deriving (Eq, Show, Generic)--instance Binary ElaboratedPackageOrComponent-instance Structured ElaboratedPackageOrComponent--elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName-elabComponentName elab =-    case elabPkgOrComp elab of-        ElabPackage _      -> Just $ CLibName LMainLibName -- there could be more, but default this-        ElabComponent comp -> compComponentName comp---- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'.-elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String-elabConfiguredName verbosity elab-    | verbosity <= normal-    = (case elabPkgOrComp elab of-        ElabPackage _ -> ""-        ElabComponent comp ->-            case compComponentName comp of-                Nothing -> "setup from "-                Just (CLibName LMainLibName) -> ""-                Just cname -> prettyShow cname ++ " from ")-      ++ prettyShow (packageId elab)-    | otherwise-    = prettyShow (elabUnitId elab)--elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams-elabDistDirParams shared elab = DistDirParams {-        distParamUnitId = installedUnitId elab,-        distParamComponentId = elabComponentId elab,-        distParamPackageId = elabPkgSourceId elab,-        distParamComponentName = case elabPkgOrComp elab of-            ElabComponent comp -> compComponentName comp-            ElabPackage _ -> Nothing,-        distParamCompilerId = compilerId (pkgConfigCompiler shared),-        distParamPlatform = pkgConfigPlatform shared,-        distParamOptimization = elabOptimization elab-    }---- | The full set of dependencies which dictate what order we--- need to build things in the install plan: "order dependencies"--- balls everything together.  This is mostly only useful for--- ordering; if you are, for example, trying to compute what--- @--dependency@ flags to pass to a Setup script, you need to--- use 'elabLibDependencies'.  This method is the same as--- 'nodeNeighbors'.------ NB: this method DOES include setup deps.-elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId]-elabOrderDependencies elab =-    case elabPkgOrComp elab of-        -- Important not to have duplicates: otherwise InstallPlan gets-        -- confused.-        ElabPackage pkg    -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))-        ElabComponent comp -> compOrderDependencies comp---- | Like 'elabOrderDependencies', but only returns dependencies on--- libraries.-elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId]-elabOrderLibDependencies elab =-    case elabPkgOrComp elab of-        ElabPackage pkg    -> map (newSimpleUnitId . confInstId) $-                              ordNub $ CD.flatDeps (pkgLibDependencies pkg)-        ElabComponent comp -> compOrderLibDependencies comp---- | The library dependencies (i.e., the libraries we depend on, NOT--- the dependencies of the library), NOT including setup dependencies.--- These are passed to the @Setup@ script via @--dependency@.-elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]-elabLibDependencies elab =-    case elabPkgOrComp elab of-        ElabPackage pkg    -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg))-        ElabComponent comp -> compLibDependencies comp---- | Like 'elabOrderDependencies', but only returns dependencies on--- executables.  (This coincides with 'elabExeDependencies'.)-elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId]-elabOrderExeDependencies =-    map newSimpleUnitId . elabExeDependencies---- | The executable dependencies (i.e., the executables we depend on);--- these are the executables we must add to the PATH before we invoke--- the setup script.-elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId]-elabExeDependencies elab = map confInstId $-    case elabPkgOrComp elab of-        ElabPackage pkg    -> CD.nonSetupDeps (pkgExeDependencies pkg)-        ElabComponent comp -> compExeDependencies comp---- | This returns the paths of all the executables we depend on; we--- must add these paths to PATH before invoking the setup script.--- (This is usually what you want, not 'elabExeDependencies', if you--- actually want to build something.)-elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath]-elabExeDependencyPaths elab =-    case elabPkgOrComp elab of-        ElabPackage pkg    -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg)-        ElabComponent comp -> map snd (compExeDependencyPaths comp)---- | The setup dependencies (the library dependencies of the setup executable;--- note that it is not legal for setup scripts to have executable--- dependencies at the moment.)-elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]-elabSetupDependencies elab =-    case elabPkgOrComp elab of-        ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg)-        -- TODO: Custom setups not supported for components yet.  When-        -- they are, need to do this differently-        ElabComponent _ -> []--elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)]-elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg }-    = pkgPkgConfigDependencies pkg-elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }-    = compPkgConfigDependencies comp---- | The cache files of all our inplace dependencies which,--- when updated, require us to rebuild.  See #4202 for--- more details.  Essentially, this is a list of filepaths--- that, if our dependencies get rebuilt, will themselves--- get updated.------ Note: the hash of these cache files gets built into--- the build cache ourselves, which means that we end--- up tracking transitive dependencies!------ Note: This tracks the "build" cache file, but not--- "registration" or "config" cache files.  Why not?--- Arguably we should...------ Note: This is a bit of a hack, because it is not really--- the hashes of the SOURCES of our (transitive) dependencies--- that we should use to decide whether or not to rebuild,--- but the output BUILD PRODUCTS.  The strategy we use--- here will never work if we want to implement unchanging--- rebuilds.-elabInplaceDependencyBuildCacheFiles-    :: DistDirLayout-    -> ElaboratedSharedConfig-    -> ElaboratedInstallPlan-    -> ElaboratedConfiguredPackage-    -> [FilePath]-elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab =-    go =<< InstallPlan.directDeps plan (nodeKey root_elab)-  where-    go = InstallPlan.foldPlanPackage (const []) $ \elab -> do-            guard (elabBuildStyle elab == BuildInplaceOnly)-            return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build"---- | Some extra metadata associated with an--- 'ElaboratedConfiguredPackage' which indicates that the "package"--- in question is actually a single component to be built.  Arguably--- it would be clearer if there were an ADT which branched into--- package work items and component work items, but I've structured--- it this way to minimize change to the existing code (which I--- don't feel qualified to rewrite.)-data ElaboratedComponent-   = ElaboratedComponent {-    -- | The name of the component to be built according to the solver-    compSolverName :: CD.Component,-    -- | The name of the component to be built.  Nothing if-    -- it's a setup dep.-    compComponentName :: Maybe ComponentName,-    -- | The *external* library dependencies of this component.  We-    -- pass this to the configure script.-    compLibDependencies :: [ConfiguredId],-    -- | In a component prior to instantiation, this list specifies-    -- the 'OpenUnitId's which, after instantiation, are the-    -- actual dependencies of this package.  Note that this does-    -- NOT include signature packages, which do not turn into real-    -- ordering dependencies when we instantiate.  This is intended to be-    -- a purely temporary field, to carry some information to the-    -- instantiation phase. It's more precise than-    -- 'compLibDependencies', and also stores information about internal-    -- dependencies.-    compLinkedLibDependencies :: [OpenUnitId],-    -- | The executable dependencies of this component (including-    -- internal executables).-    compExeDependencies :: [ConfiguredId],-    -- | The @pkg-config@ dependencies of the component-    compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)],-    -- | The paths all our executable dependencies will be installed-    -- to once they are installed.-    compExeDependencyPaths :: [(ConfiguredId, FilePath)],-    -- | The UnitIds of the libraries (identifying elaborated packages/-    -- components) that must be built before this project.  This-    -- is used purely for ordering purposes.  It can contain both-    -- references to definite and indefinite packages; an indefinite-    -- UnitId indicates that we must typecheck that indefinite package-    -- before we can build this one.-    compOrderLibDependencies :: [UnitId]-   }-  deriving (Eq, Show, Generic)--instance Binary ElaboratedComponent-instance Structured ElaboratedComponent---- | See 'elabOrderDependencies'.-compOrderDependencies :: ElaboratedComponent -> [UnitId]-compOrderDependencies comp =-    compOrderLibDependencies comp- ++ compOrderExeDependencies comp---- | See 'elabOrderExeDependencies'.-compOrderExeDependencies :: ElaboratedComponent -> [UnitId]-compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies--data ElaboratedPackage-   = ElaboratedPackage {-       pkgInstalledId :: InstalledPackageId,--       -- | The exact dependencies (on other plan packages)-       ---       pkgLibDependencies :: ComponentDeps [ConfiguredId],--       -- | Components which depend (transitively) on an internally-       -- defined library.  These are used by 'elabRequiresRegistration',-       -- to determine if a user-requested build is going to need-       -- a library registration-       ---       pkgDependsOnSelfLib :: ComponentDeps [()],--       -- | Dependencies on executable packages.-       ---       pkgExeDependencies :: ComponentDeps [ConfiguredId],--       -- | Paths where executable dependencies live.-       ---       pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)],--       -- | Dependencies on @pkg-config@ packages.-       -- NB: this is NOT per-component (although it could be)-       -- because Cabal library does not track per-component-       -- pkg-config depends; it always does them all at once.-       ---       pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)],--       -- | Which optional stanzas (ie testsuites, benchmarks) will actually-       -- be enabled during the package configure step.-       pkgStanzasEnabled :: Set OptionalStanza-     }-  deriving (Eq, Show, Generic)--instance Binary ElaboratedPackage-instance Structured ElaboratedPackage---- | See 'elabOrderDependencies'.  This gives the unflattened version,--- which can be useful in some circumstances.-pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId]-pkgOrderDependencies pkg =-    fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend`-    fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg)---- | This is used in the install plan to indicate how the package will be--- built.----data BuildStyle =-    -- | The classic approach where the package is built, then the files-    -- installed into some location and the result registered in a package db.-    ---    -- If the package came from a tarball then it's built in a temp dir and-    -- the results discarded.-    BuildAndInstall--    -- | The package is built, but the files are not installed anywhere,-    -- rather the build dir is kept and the package is registered inplace.-    ---    -- Such packages can still subsequently be installed.-    ---    -- Typically 'BuildAndInstall' packages will only depend on other-    -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.-    ---  | BuildInplaceOnly-  deriving (Eq, Show, Generic)--instance Binary BuildStyle-instance Structured BuildStyle--type CabalFileText = LBS.ByteString--type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage--------------------------------- Build targets------- | Specific targets within a package or component to act on e.g. to build,--- haddock or open a repl.----data ComponentTarget = ComponentTarget ComponentName SubComponentTarget-  deriving (Eq, Ord, Show, Generic)--instance Binary ComponentTarget-instance Structured ComponentTarget---- | Unambiguously render a 'ComponentTarget', e.g., to pass--- to a Cabal Setup script.-showComponentTarget :: PackageId -> ComponentTarget -> String-showComponentTarget pkgid =-    Cabal.showBuildTarget pkgid . toBuildTarget-  where-    toBuildTarget :: ComponentTarget -> Cabal.BuildTarget-    toBuildTarget (ComponentTarget cname subtarget) =-      case subtarget of-        WholeComponent     -> Cabal.BuildTargetComponent cname-        ModuleTarget mname -> Cabal.BuildTargetModule    cname mname-        FileTarget   fname -> Cabal.BuildTargetFile      cname fname--showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String-showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n-showTestComponentTarget _ _ = Nothing--isTestComponentTarget :: ComponentTarget -> Bool-isTestComponentTarget (ComponentTarget (CTestName _) _) = True-isTestComponentTarget _                                 = False--showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String-showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n-showBenchComponentTarget _ _ = Nothing--isBenchComponentTarget :: ComponentTarget -> Bool-isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True-isBenchComponentTarget _                                  = False--isForeignLibComponentTarget :: ComponentTarget -> Bool-isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True-isForeignLibComponentTarget _                                 = False--isExeComponentTarget :: ComponentTarget -> Bool-isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True-isExeComponentTarget _                                 = False--isSubLibComponentTarget :: ComponentTarget -> Bool-isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True-isSubLibComponentTarget _                                              = False--componentOptionalStanza :: CD.Component -> Maybe OptionalStanza-componentOptionalStanza (CD.ComponentTest _)  = Just TestStanzas-componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas-componentOptionalStanza _                     = Nothing-------------------------------- Setup.hs script policy------- | There are four major cases for Setup.hs handling:------  1. @build-type@ Custom with a @custom-setup@ section---  2. @build-type@ Custom without a @custom-setup@ section---  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@---  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@------ It's also worth noting that packages specifying @cabal-version: >= 1.23@--- or later that have @build-type@ Custom will always have a @custom-setup@--- section. Therefore in case 2, the specified @cabal-version@ will always be--- less than 1.23.------ In cases 1 and 2 we obviously have to build an external Setup.hs script,--- while in case 4 we can use the internal library API. In case 3 we also have--- to build an external Setup.hs script because the package needs a later--- Cabal lib version than we can support internally.----data SetupScriptStyle = SetupCustomExplicitDeps-                      | SetupCustomImplicitDeps-                      | SetupNonCustomExternalLib-                      | SetupNonCustomInternalLib-  deriving (Eq, Show, Generic, Typeable)--instance Binary SetupScriptStyle-instance Structured SetupScriptStyle
− Distribution/Client/RebuildMonad.hs 
@@ -1,310 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-}---- | An abstraction for re-running actions if values or files have changed.------ This is not a full-blown make-style incremental build system, it's a bit--- more ad-hoc than that, but it's easier to integrate with existing code.------ It's a convenient interface to the "Distribution.Client.FileMonitor"--- functions.----module Distribution.Client.RebuildMonad (-    -- * Rebuild monad-    Rebuild,-    runRebuild,-    execRebuild,-    askRoot,--    -- * Setting up file monitoring-    monitorFiles,-    MonitorFilePath,-    monitorFile,-    monitorFileHashed,-    monitorNonExistentFile,-    monitorDirectory,-    monitorNonExistentDirectory,-    monitorDirectoryExistence,-    monitorFileOrDirectory,-    monitorFileSearchPath,-    monitorFileHashedSearchPath,-    -- ** Monitoring file globs-    monitorFileGlob,-    monitorFileGlobExistence,-    FilePathGlob(..),-    FilePathRoot(..),-    FilePathGlobRel(..),-    GlobPiece(..),--    -- * Using a file monitor-    FileMonitor(..),-    newFileMonitor,-    rerunIfChanged,--    -- * Utils-    delayInitSharedResource,-    delayInitSharedResources,-    matchFileGlob,-    getDirectoryContentsMonitored,-    createDirectoryMonitored,-    monitorDirectoryStatus,-    doesFileExistMonitored,-    need,-    needIfExists,-    findFileWithExtensionMonitored,-    findFirstFileMonitored,-    findFileMonitored,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.FileMonitor-import Distribution.Client.Glob hiding (matchFileGlob)-import qualified Distribution.Client.Glob as Glob (matchFileGlob)--import Distribution.Simple.Utils (debug)--import qualified Data.Map.Strict as Map-import Control.Monad.State as State-import Control.Monad.Reader as Reader-import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)-import System.FilePath-import System.Directory----- | A monad layered on top of 'IO' to help with re-running actions when the--- input files and values they depend on change. The crucial operations are--- 'rerunIfChanged' and 'monitorFiles'.----newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)-  deriving (Functor, Applicative, Monad, MonadIO)---- | Use this wihin the body action of 'rerunIfChanged' to declare that the--- action depends on the given files. This can be based on what the action--- actually did. It is these files that will be checked for changes next--- time 'rerunIfChanged' is called for that 'FileMonitor'.------ Relative paths are interpreted as relative to an implicit root, ultimately--- passed in to 'runRebuild'.----monitorFiles :: [MonitorFilePath] -> Rebuild ()-monitorFiles filespecs = Rebuild (State.modify (filespecs++))---- | Run a 'Rebuild' IO action.-unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])-unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []---- | Run a 'Rebuild' IO action.-runRebuild :: FilePath -> Rebuild a -> IO a-runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []---- | Run a 'Rebuild' IO action.-execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]-execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) []---- | The root that relative paths are interpreted as being relative to.-askRoot :: Rebuild FilePath-askRoot = Rebuild Reader.ask---- | This captures the standard use pattern for a 'FileMonitor': given a--- monitor, an action and the input value the action depends on, either--- re-run the action to get its output, or if the value and files the action--- depends on have not changed then return a previously cached action result.------ The result is still in the 'Rebuild' monad, so these can be nested.------ Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.----rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b)-               => Verbosity-               -> FileMonitor a b-               -> a-               -> Rebuild b-               -> Rebuild b-rerunIfChanged verbosity monitor key action = do-    rootDir <- askRoot-    changed <- liftIO $ checkFileMonitorChanged monitor rootDir key-    case changed of-      MonitorUnchanged result files -> do-        liftIO $ debug verbosity $ "File monitor '" ++ monitorName-                                                    ++ "' unchanged."-        monitorFiles files-        return result--      MonitorChanged reason -> do-        liftIO $ debug verbosity $ "File monitor '" ++ monitorName-                                ++ "' changed: " ++ showReason reason-        startTime <- liftIO $ beginUpdateFileMonitor-        (result, files) <- liftIO $ unRebuild rootDir action-        liftIO $ updateFileMonitor monitor rootDir-                                   (Just startTime) files key result-        monitorFiles files-        return result-  where-    monitorName = takeFileName (fileMonitorCacheFile monitor)--    showReason (MonitoredFileChanged file) = "file " ++ file-    showReason (MonitoredValueChanged _)   = "monitor value changed"-    showReason  MonitorFirstRun            = "first run"-    showReason  MonitorCorruptCache        = "invalid cache file"----- | When using 'rerunIfChanged' for each element of a list of actions, it is--- sometimes the case that each action needs to make use of some resource. e.g.------ > sequence--- >   [ rerunIfChanged verbosity monitor key $ do--- >       resource <- mkResource--- >       ... -- use the resource--- >   | ... ]------ For efficiency one would like to share the resource between the actions--- but the straightforward way of doing this means initialising it every time--- even when no actions need re-running.------ > resource <- mkResource--- > sequence--- >   [ rerunIfChanged verbosity monitor key $ do--- >       ... -- use the resource--- >   | ... ]------ This utility allows one to get the best of both worlds:------ > getResource <- delayInitSharedResource mkResource--- > sequence--- >   [ rerunIfChanged verbosity monitor key $ do--- >       resource <- getResource--- >       ... -- use the resource--- >   | ... ]----delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)-delayInitSharedResource action = do-    var <- liftIO (newMVar Nothing)-    return (liftIO (getOrInitResource var))-  where-    getOrInitResource :: MVar (Maybe a) -> IO a-    getOrInitResource var =-      modifyMVar var $ \mx ->-        case mx of-          Just x  -> return (Just x, x)-          Nothing -> do-            x <- action-            return (Just x, x)----- | Much like 'delayInitSharedResource' but for a keyed set of resources.------ > getResource <- delayInitSharedResource mkResource--- > sequence--- >   [ rerunIfChanged verbosity monitor key $ do--- >       resource <- getResource key--- >       ... -- use the resource--- >   | ... ]----delayInitSharedResources :: forall k v. Ord k-                         => (k -> IO v)-                         -> Rebuild (k -> Rebuild v)-delayInitSharedResources action = do-    var <- liftIO (newMVar Map.empty)-    return (liftIO . getOrInitResource var)-  where-    getOrInitResource :: MVar (Map k v) -> k -> IO v-    getOrInitResource var k =-      modifyMVar var $ \m ->-        case Map.lookup k m of-          Just x  -> return (m, x)-          Nothing -> do-            x <- action k-            let !m' = Map.insert k x m-            return (m', x)----- | Utility to match a file glob against the file system, starting from a--- given root directory. The results are all relative to the given root.------ Since this operates in the 'Rebuild' monad, it also monitors the given glob--- for changes.----matchFileGlob :: FilePathGlob -> Rebuild [FilePath]-matchFileGlob glob = do-    root <- askRoot-    monitorFiles [monitorFileGlobExistence glob]-    liftIO $ Glob.matchFileGlob root glob--getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]-getDirectoryContentsMonitored dir = do-    exists <- monitorDirectoryStatus dir-    if exists-      then liftIO $ getDirectoryContents dir-      else return []--createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()-createDirectoryMonitored createParents dir = do-    monitorFiles [monitorDirectoryExistence dir]-    liftIO $ createDirectoryIfMissing createParents dir---- | Monitor a directory as in 'monitorDirectory' if it currently exists or--- as 'monitorNonExistentDirectory' if it does not.-monitorDirectoryStatus :: FilePath -> Rebuild Bool-monitorDirectoryStatus dir = do-    exists <- liftIO $ doesDirectoryExist dir-    monitorFiles [if exists-                    then monitorDirectory dir-                    else monitorNonExistentDirectory dir]-    return exists---- | Like 'doesFileExist', but in the 'Rebuild' monad.  This does--- NOT track the contents of 'FilePath'; use 'need' in that case.-doesFileExistMonitored :: FilePath -> Rebuild Bool-doesFileExistMonitored f = do-    root <- askRoot-    exists <- liftIO $ doesFileExist (root </> f)-    monitorFiles [if exists-                    then monitorFileExistence f-                    else monitorNonExistentFile f]-    return exists---- | Monitor a single file-need :: FilePath -> Rebuild ()-need f = monitorFiles [monitorFileHashed f]---- | Monitor a file if it exists; otherwise check for when it--- gets created.  This is a bit better for recompilation avoidance--- because sometimes users give bad package metadata, and we don't--- want to repeatedly rebuild in this case (which we would if we--- need'ed a non-existent file).-needIfExists :: FilePath -> Rebuild ()-needIfExists f = do-    root <- askRoot-    exists <- liftIO $ doesFileExist (root </> f)-    monitorFiles [if exists-                    then monitorFileHashed f-                    else monitorNonExistentFile f]---- | Like 'findFileWithExtension', but in the 'Rebuild' monad.-findFileWithExtensionMonitored-    :: [String]-    -> [FilePath]-    -> FilePath-    -> Rebuild (Maybe FilePath)-findFileWithExtensionMonitored extensions searchPath baseName =-  findFirstFileMonitored id-    [ path </> baseName <.> ext-    | path <- nub searchPath-    , ext <- nub extensions ]---- | Like 'findFirstFile', but in the 'Rebuild' monad.-findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)-findFirstFileMonitored file = findFirst-  where findFirst []     = return Nothing-        findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)-                              if exists-                                then return (Just x)-                                else findFirst xs---- | Like 'findFile', but in the 'Rebuild' monad.-findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)-findFileMonitored searchPath fileName =-  findFirstFileMonitored id-    [ path </> fileName-    | path <- nub searchPath]
− Distribution/Client/Reconfigure.hs 
@@ -1,179 +0,0 @@-module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where--import Distribution.Client.Compat.Prelude--import Data.Monoid ( Any(..) )-import System.Directory ( doesFileExist )--import Distribution.Simple.Configure ( localBuildInfoFile )-import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag )-import Distribution.Simple.Utils-       ( existsAndIsMoreRecentThan, defaultPackageDesc, info )--import Distribution.Client.Config ( SavedConfig(..) )-import Distribution.Client.Configure ( readConfigFlags )-import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate )-import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs )-import Distribution.Client.Sandbox.PackageEnvironment-       ( userPackageEnvironmentFile )-import Distribution.Client.Setup-       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) )---- | @Check@ represents a function to check some condition on type @a@. The--- returned 'Any' is 'True' if any part of the condition failed.-newtype Check a = Check {-  runCheck :: Any          -- Did any previous check fail?-           -> a            -- value returned by previous checks-           -> IO (Any, a)  -- Did this check fail? What value is returned?-}--instance Semigroup (Check a) where-  (<>) c d = Check $ \any0 a0 -> do-    (any1, a1) <- runCheck c any0 a0-    (any2, a2) <- runCheck d (any0 <> any1) a1-    return (any0 <> any1 <> any2, a2)--instance Monoid (Check a) where-  mempty = Check $ \_ a -> return (mempty, a)-  mappend = (<>)----- | Re-configure the package in the current directory if needed. Deciding--- when to reconfigure and with which options is convoluted:------ If we are reconfiguring, we must always run @configure@ with the--- verbosity option we are given; however, that a previous configuration--- uses a different verbosity setting is not reason enough to reconfigure.------ The package should be configured to use the same \"dist\" prefix as--- given to the @build@ command, otherwise the build will probably--- fail. Not only does this determine the \"dist\" prefix setting if we--- need to reconfigure anyway, but an existing configuration should be--- invalidated if its \"dist\" prefix differs.------ If the package has never been configured (i.e., there is no--- LocalBuildInfo), we must configure first, using the default options.------ If the package has been configured, there will be a 'LocalBuildInfo'.--- If there no package description file, we assume that the--- 'PackageDescription' is up to date, though the configuration may need--- to be updated for other reasons (see above). If there is a package--- description file, and it has been modified since the 'LocalBuildInfo'--- was generated, then we need to reconfigure.------ The caller of this function may also have specific requirements--- regarding the flags the last configuration used. For example,--- 'testAction' requires that the package be configured with test suites--- enabled. The caller may pass the required settings to this function--- along with a function to check the validity of the saved 'ConfigFlags';--- these required settings will be checked first upon determining that--- a previous configuration exists.-reconfigure-  :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())-     -- ^ configure action-  -> Verbosity-     -- ^ Verbosity setting-  -> FilePath-     -- ^ \"dist\" prefix-  -> Flag (Maybe Int)-     -- ^ -j flag for reinstalling add-source deps.-  -> Check (ConfigFlags, ConfigExFlags)-     -- ^ Check that the required flags are set.-     -- If they are not set, provide a message explaining the-     -- reason for reconfiguration.-  -> [String]     -- ^ Extra arguments-  -> GlobalFlags  -- ^ Global flags-  -> SavedConfig-  -> IO SavedConfig-reconfigure-  configureAction-  verbosity-  dist-  _numJobsFlag-  check-  extraArgs-  globalFlags-  config-  = do--  savedFlags@(_, _) <- readConfigFlags dist--  useNix <- fmap isJust (findNixExpr globalFlags config)-  alreadyInNixShell <- inNixShell--  if useNix && not alreadyInNixShell-    then do--      -- If we are using Nix, we must reinstantiate the derivation outside-      -- the shell. Eventually, the caller will invoke 'nixShell' which will-      -- rerun cabal inside the shell. That will bring us back to 'reconfigure',-      -- but inside the shell we'll take the second branch, below.--      -- This seems to have a problem: won't 'configureAction' call 'nixShell'-      -- yet again, spawning an infinite tree of subprocesses?-      -- No, because 'nixShell' doesn't spawn a new process if it is already-      -- running in a Nix shell.--      nixInstantiate verbosity dist False globalFlags config-      return config--    else do--      let checks =-            checkVerb-            <> checkDist-            <> checkOutdated-            <> check-      (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags--      let config' = updateInstallDirs (configUserInstall configFlags) config--      when frc $ configureAction flags extraArgs globalFlags-      return config'--  where--    -- Changing the verbosity does not require reconfiguration, but the new-    -- verbosity should be used if reconfiguring.-    checkVerb = Check $ \_ (configFlags, configExFlags) -> do-      let configFlags' = configFlags { configVerbosity = toFlag verbosity}-      return (mempty, (configFlags', configExFlags))--    -- Reconfiguration is required if @--build-dir@ changes.-    checkDist = Check $ \_ (configFlags, configExFlags) -> do-      -- Always set the chosen @--build-dir@ before saving the flags,-      -- or bad things could happen.-      savedDist <- findSavedDistPref config (configDistPref configFlags)-      let distChanged = dist /= savedDist-      when distChanged $ info verbosity "build directory changed"-      let configFlags' = configFlags { configDistPref = toFlag dist }-      return (Any distChanged, (configFlags', configExFlags))--    checkOutdated = Check $ \_ flags@(configFlags, _) -> do-      let buildConfig = localBuildInfoFile dist--      -- Has the package ever been configured? If not, reconfiguration is-      -- required.-      configured <- doesFileExist buildConfig-      unless configured $ info verbosity "package has never been configured"--      -- 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@-      -- even without sandboxes.-      userPackageEnvironmentFileModified <--        existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig-      when userPackageEnvironmentFileModified $-        info verbosity ("user package environment file ('"-        ++ userPackageEnvironmentFile ++ "') was modified")--      -- Is the configuration older than the package description?-      descrFile <- maybe (defaultPackageDesc verbosity) return-                   (flagToMaybe (configCabalFilePath configFlags))-      outdated <- existsAndIsMoreRecentThan descrFile buildConfig-      when outdated $ info verbosity (descrFile ++ " was changed")--      let failed =-            Any outdated-            <> Any userPackageEnvironmentFileModified-            <> Any (not configured)-      return (failed, flags)
− Distribution/Client/Run.hs 
@@ -1,141 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Run--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Implementation of the 'run' command.--------------------------------------------------------------------------------module Distribution.Client.Run ( run, splitRunArgs )-       where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Types.TargetInfo     (targetCLBI)-import Distribution.Types.LocalBuildInfo (componentNameTargets')--import Distribution.Client.Utils             (tryCanonicalizePath)--import Distribution.Types.UnqualComponentName-import Distribution.PackageDescription       (Executable (..),-                                              TestSuite(..),-                                              Benchmark(..),-                                              PackageDescription (..),-                                              BuildInfo(buildable))-import Distribution.Simple.Compiler          (compilerFlavor, CompilerFlavor(..))-import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)-import Distribution.Simple.BuildPaths        (exeExtension)-import Distribution.Simple.LocalBuildInfo    (ComponentName (..),-                                              LocalBuildInfo (..),-                                              depLibraryPaths)-import Distribution.Simple.Utils             (die', notice, warn,-                                              rawSystemExitWithEnv,-                                              addLibraryPath)-import Distribution.System                   (Platform (..))--import qualified Distribution.Simple.GHCJS as GHCJS--import System.Directory                      (getCurrentDirectory)-import Distribution.Compat.Environment       (getEnvironment)-import System.FilePath                       ((<.>), (</>))----- | Return the executable to run and any extra arguments that should be--- forwarded to it. Die in case of error.-splitRunArgs :: Verbosity -> LocalBuildInfo -> [String]-             -> IO (Executable, [String])-splitRunArgs verbosity lbi args =-  case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)-    Left err               -> do-      warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.-      die' verbosity err-    Right (True, exe, xs)  -> return (exe, xs)-    Right (False, exe, xs) -> do-      let addition = " Interpreting all parameters to `run` as a parameter to"-                     ++ " the default executable."-      -- If there is a warning, print it together with the addition.-      warn verbosity `traverse_` fmap (++addition) maybeWarning-      return (exe, xs)-  where-    pkg_descr = localPkgDescr lbi-    whichExecutable :: Either String       -- Error string.-                              ( Bool       -- If it was manually chosen.-                              , Executable -- The executable.-                              , [String]   -- The remaining parameters.-                              )-    whichExecutable = case (enabledExes, args) of-      ([]   , _)           -> Left "Couldn't find any enabled executables."-      ([exe], [])          -> return (False, exe, [])-      ([exe], (x:xs))-        | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)-        | otherwise                                -> return (False, exe, args)-      (_    , [])                                  -> Left-        $ "This package contains multiple executables. "-        ++ "You must pass the executable name as the first argument "-        ++ "to 'cabal run'."-      (_    , (x:xs))      ->-        case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of-          Nothing  -> Left $ "No executable named '" ++ x ++ "'."-          Just exe -> return (True, exe, xs)-      where-        enabledExes = filter (buildable . buildInfo) (executables pkg_descr)--    maybeWarning :: Maybe String-    maybeWarning = case args of-      []    -> Nothing-      (x:_) -> lookup (mkUnqualComponentName x) components-      where-        components :: [(UnqualComponentName, String)] -- Component name, message.-        components =-          [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.")-          | e <- executables pkg_descr-          , not . buildable . buildInfo $ e, let name = exeName e]--          ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "',"-                      ++ " but the `run` command is only for executables.")-             | t <- testSuites pkg_descr-             , let name = testName t]--          ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "',"-                      ++ " but the `run` command is only for executables.")-             | b <- benchmarks pkg_descr-             , let name = benchmarkName b]---- | Run a given executable.-run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()-run verbosity lbi exe exeArgs = do-  curDir <- getCurrentDirectory-  let buildPref     = buildDir lbi-      pkg_descr     = localPkgDescr lbi-      dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",-                       curDir </> dataDir pkg_descr)--  (path, runArgs) <--    let exeName' = prettyShow $ exeName exe-    in case compilerFlavor (compiler lbi) of-      GHCJS -> do-        let (script, cmd, cmdArgs) =-              GHCJS.runCmd (withPrograms lbi)-                           (buildPref </> exeName' </> exeName')-        script' <- tryCanonicalizePath script-        return (cmd, cmdArgs ++ [script'])-      _     -> do-         p <- tryCanonicalizePath $-            buildPref </> exeName' </> (exeName' <.> exeExtension (hostPlatform lbi))-         return (p, [])--  env  <- (dataDirEnvVar:) <$> getEnvironment-  -- Add (DY)LD_LIBRARY_PATH if needed-  env' <- if withDynExe lbi-             then do let (Platform _ os) = hostPlatform lbi-                     clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of-                                [target] -> return (targetCLBI target)-                                [] -> die' verbosity "run: Could not find executable in LocalBuildInfo"-                                _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo"-                     paths <- depLibraryPaths True False lbi clbi-                     return (addLibraryPath os paths env)-             else return env-  notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..."-  rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'
− Distribution/Client/Sandbox.hs 
@@ -1,122 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Sandbox--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ UI for the sandboxing functionality.--------------------------------------------------------------------------------module Distribution.Client.Sandbox (-    loadConfigOrSandboxConfig,-    findSavedDistPref,--    updateInstallDirs,--    getPersistOrConfigCompiler-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Client.Setup-  ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' )-import Distribution.Client.Config-  ( SavedConfig(..), defaultUserInstall, loadConfig )--import Distribution.Client.Sandbox.PackageEnvironment-  (  PackageEnvironmentType(..)-  , classifyPackageEnvironment-  , loadUserConfig-  )-import Distribution.Client.SetupWrapper-  ( SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Simple.Compiler           ( Compiler(..) )-import Distribution.Simple.Configure          ( maybeGetPersistBuildConfig-                                              , findDistPrefOrDefault-                                              , findDistPref )-import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo-import Distribution.Simple.Program            ( ProgramDb )-import Distribution.Simple.Setup              ( Flag(..)-                                              , fromFlagOrDefault, flagToMaybe )-import Distribution.System                    ( Platform )--import System.Directory                       ( getCurrentDirectory )----- * Basic sandbox functions.-----updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig-updateInstallDirs userInstallFlag savedConfig = savedConfig-    { savedConfigureFlags = configureFlags-        { configInstallDirs = installDirs-        }-    }-  where-    configureFlags = savedConfigureFlags savedConfig-    userInstallDirs = savedUserInstallDirs savedConfig-    globalInstallDirs = savedGlobalInstallDirs savedConfig-    installDirs | userInstall = userInstallDirs-                | otherwise   = globalInstallDirs-    userInstall = fromFlagOrDefault defaultUserInstall-                  (configUserInstall configureFlags `mappend` userInstallFlag)---- | Check which type of package environment we're in and return a--- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates--- whether we're working in a sandbox.-loadConfigOrSandboxConfig :: Verbosity-                          -> GlobalFlags  -- ^ For @--config-file@ and-                                          -- @--sandbox-config-file@.-                          -> IO SavedConfig-loadConfigOrSandboxConfig verbosity globalFlags = do-  let configFileFlag        = globalConfigFile        globalFlags--  pkgEnvDir  <- getCurrentDirectory-  pkgEnvType <- classifyPackageEnvironment pkgEnvDir-  case pkgEnvType of-    -- Only @cabal.config@ is present.-    UserPackageEnvironment    -> do-      config <- loadConfig verbosity configFileFlag-      userConfig <- loadUserConfig verbosity pkgEnvDir Nothing-      let config' = config `mappend` userConfig-      return config'--    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.-    AmbientPackageEnvironment -> do-      config <- loadConfig verbosity configFileFlag-      let globalConstraintsOpt =-            flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config-      globalConstraintConfig <--        loadUserConfig verbosity pkgEnvDir globalConstraintsOpt-      let config' = config `mappend` globalConstraintConfig-      return config'---- | Return the saved \"dist/\" prefix, or the default prefix.-findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath-findSavedDistPref config flagDistPref = do-    let defDistPref = useDistPref defaultSetupScriptOptions-        flagDistPref' = configDistPref (savedConfigureFlags config)-                        `mappend` flagDistPref-    findDistPref defDistPref flagDistPref'---- Utils (transitionary)------- | Try to read the most recently configured compiler from the--- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it--- cannot be read.-getPersistOrConfigCompiler :: ConfigFlags-                           -> IO (Compiler, Platform, ProgramDb)-getPersistOrConfigCompiler configFlags = do-  distPref <- findDistPrefOrDefault (configDistPref configFlags)-  mlbi <- maybeGetPersistBuildConfig distPref-  case mlbi of-    Nothing  -> do configCompilerAux' configFlags-    Just lbi -> return ( LocalBuildInfo.compiler lbi-                       , LocalBuildInfo.hostPlatform lbi-                       , LocalBuildInfo.withPrograms lbi-                       )
− Distribution/Client/Sandbox/PackageEnvironment.hs 
@@ -1,284 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Sandbox.PackageEnvironment--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Utilities for working with the package environment file. Patterned after--- Distribution.Client.Config.--------------------------------------------------------------------------------module Distribution.Client.Sandbox.PackageEnvironment (-    PackageEnvironment(..)-  , PackageEnvironmentType(..)-  , classifyPackageEnvironment-  , readPackageEnvironmentFile-  , showPackageEnvironment-  , showPackageEnvironmentWithComments-  , loadUserConfig--  , userPackageEnvironmentFile-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.Config      ( SavedConfig(..) -                                       , configFieldDescriptions-                                       , haddockFlagsFields-                                       , installDirsFields, withProgramsFields-                                       , withProgramOptionsFields-                                       )-import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )-import Distribution.Client.Setup       ( ConfigExFlags(..)-                                       )-import Distribution.Client.Targets     ( userConstraintPackageName )-import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate )-import Distribution.Simple.Setup       ( Flag(..)-                                       , ConfigFlags(..), HaddockFlags(..)-                                       )-import Distribution.Simple.Utils       ( warn, debug )-import Distribution.Solver.Types.ConstraintSource-import Distribution.Deprecated.ParseUtils         ( FieldDescr(..), ParseResult(..)-                                       , commaListFieldParsec, commaNewLineListFieldParsec-                                       , liftField, lineNo, locatedErrorMsg-                                       , readFields-                                       , showPWarning -                                       , syntaxError, warning )-import System.Directory                ( doesFileExist )-import System.FilePath                 ( (</>) )-import System.IO.Error                 ( isDoesNotExistError )-import Text.PrettyPrint                ( ($+$) )--import qualified Text.PrettyPrint          as Disp-import qualified Distribution.Deprecated.ParseUtils   as ParseUtils ( Field(..) )------- * Configuration saved in the package environment file------- TODO: would be nice to remove duplication between--- D.C.Sandbox.PackageEnvironment and D.C.Config.-data PackageEnvironment = PackageEnvironment {-  pkgEnvSavedConfig   :: SavedConfig-} deriving Generic--instance Monoid PackageEnvironment where-  mempty = gmempty-  mappend = (<>)--instance Semigroup PackageEnvironment where-  (<>) = gmappend---- | Optional package environment file that can be used to customize the default--- settings. Created by the user.-userPackageEnvironmentFile :: FilePath-userPackageEnvironmentFile = "cabal.config"---- | Type of the current package environment.-data PackageEnvironmentType-  = UserPackageEnvironment    -- ^ './cabal.config'-  | AmbientPackageEnvironment -- ^ '~/.cabal/config'---- | Is there a 'cabal.config' in this directory?-classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType-classifyPackageEnvironment pkgEnvDir = do-     isUser <- configExists userPackageEnvironmentFile-     return (classify isUser)-  where-    configExists fname   = doesFileExist (pkgEnvDir </> fname)--    classify :: Bool -> PackageEnvironmentType-    classify True    = UserPackageEnvironment-    classify False   = AmbientPackageEnvironment----- | Load the user package environment if it exists (the optional "cabal.config"--- file). If it does not exist locally, attempt to load an optional global one.-userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath-                       -> IO PackageEnvironment-userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do-    let path = pkgEnvDir </> userPackageEnvironmentFile-    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path)-            mempty path-    case (minp, globalConfigLocation) of-      (Just parseRes, _)  -> processConfigParse path parseRes-      (_, Just globalLoc) -> do-        minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc)-                 mempty globalLoc-        maybe (warn verbosity ("no constraints file found at " ++ globalLoc)-               >> return mempty)-          (processConfigParse globalLoc)-          minp'-      _ -> do-        debug verbosity ("no user package environment file found at " ++ pkgEnvDir)-        return mempty-  where-    processConfigParse path (ParseOk warns parseResult) = do-      unless (null warns) $ warn verbosity $-        unlines (map (showPWarning path) warns)-      return parseResult-    processConfigParse path (ParseFailed err) = do-      let (line, msg) = locatedErrorMsg err-      warn verbosity $ "Error parsing package environment file " ++ path-        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg-      return mempty---- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.-loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig-loadUserConfig verbosity pkgEnvDir globalConfigLocation =-    fmap pkgEnvSavedConfig $-    userPackageEnvironment verbosity pkgEnvDir globalConfigLocation------ | Descriptions of all fields in the package environment file.-pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]-pkgEnvFieldDescrs src =-  [ commaNewLineListFieldParsec "constraints"-    (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec)-    (sortConstraints . configExConstraints-     . savedConfigureExFlags . pkgEnvSavedConfig)-    (\v pkgEnv -> updateConfigureExFlags pkgEnv-                  (\flags -> flags { configExConstraints = v }))--  , commaListFieldParsec "preferences"-    pretty parsec-    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)-    (\v pkgEnv -> updateConfigureExFlags pkgEnv-                  (\flags -> flags { configPreferences = v }))-  ]-  ++ map toPkgEnv configFieldDescriptions'-  where-    configFieldDescriptions' :: [FieldDescr SavedConfig]-    configFieldDescriptions' = filter-      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")-      (configFieldDescriptions src)--    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment-    toPkgEnv fieldDescr =-      liftField pkgEnvSavedConfig-      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})-      fieldDescr--    updateConfigureExFlags :: PackageEnvironment-                              -> (ConfigExFlags -> ConfigExFlags)-                              -> PackageEnvironment-    updateConfigureExFlags pkgEnv f = pkgEnv {-      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {-         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig-                                 $ pkgEnv-         }-      }--    sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)---- | Read the package environment file.-readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath-                              -> IO (Maybe (ParseResult PackageEnvironment))-readPackageEnvironmentFile src initial file =-  handleNotExists $-  fmap (Just . parsePackageEnvironment src initial) (readFile file)-  where-    handleNotExists action = catchIO action $ \ioe ->-      if isDoesNotExistError ioe-        then return Nothing-        else ioError ioe---- | Parse the package environment file.-parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> String-                           -> ParseResult PackageEnvironment-parsePackageEnvironment src initial str = do-  fields <- readFields str-  let (knownSections, others) = partition isKnownSection fields-  pkgEnv <- parse others-  let config       = pkgEnvSavedConfig pkgEnv-      installDirs0 = savedUserInstallDirs config-  (haddockFlags, installDirs, paths, args) <--    foldM parseSections-    (savedHaddockFlags config, installDirs0, [], [])-    knownSections-  return pkgEnv {-    pkgEnvSavedConfig = config {-       savedConfigureFlags    = (savedConfigureFlags config) {-          configProgramPaths  = paths,-          configProgramArgs   = args-          },-       savedHaddockFlags      = haddockFlags,-       savedUserInstallDirs   = installDirs,-       savedGlobalInstallDirs = installDirs-       }-    }--  where-    isKnownSection :: ParseUtils.Field -> Bool-    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 src) initial--    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."-    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])])------ | Pretty-print the package environment.-showPackageEnvironment :: PackageEnvironment -> String-showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv---- | Pretty-print the package environment with default values for empty fields--- commented out (just like the default ~/.cabal/config).-showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)-                                      -> PackageEnvironment-                                      -> String-showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $-      ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)-               mdefPkgEnv pkgEnv-  $+$ Disp.text ""-  $+$ ppSection "install-dirs" "" installDirsFields-                (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)-  where-    installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig
− Distribution/Client/SavedFlags.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Distribution.Client.SavedFlags-       ( readCommandFlags, writeCommandFlags-       , readSavedArgs, writeSavedArgs-       ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Simple.Command-import Distribution.Simple.UserHooks ( Args )-import Distribution.Simple.Utils-       ( createDirectoryIfMissingVerbose, unintersperse )-import Distribution.Verbosity--import System.Directory ( doesFileExist )-import System.FilePath ( takeDirectory )---writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO ()-writeSavedArgs verbosity path args = do-  createDirectoryIfMissingVerbose-    (lessVerbose verbosity) True (takeDirectory path)-  writeFile path (intercalate "\0" args)----- | Write command-line flags to a file, separated by null characters. This--- format is also suitable for the @xargs -0@ command. Using the null--- character also avoids the problem of escaping newlines or spaces,--- because unlike other whitespace characters, the null character is--- not valid in command-line arguments.-writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO ()-writeCommandFlags verbosity path command flags =-  writeSavedArgs verbosity path (commandShowOptions command flags)---readSavedArgs :: FilePath -> IO (Maybe [String])-readSavedArgs path = do-  exists <- doesFileExist path-  if exists-     then fmap (Just . unintersperse '\0') (readFile path)-    else return Nothing----- | Read command-line arguments, separated by null characters, from a file.--- Returns the default flags if the file does not exist.-readCommandFlags :: FilePath -> CommandUI flags -> IO flags-readCommandFlags path command = do-  savedArgs <- fmap (fromMaybe []) (readSavedArgs path)-  case (commandParseArgs command True savedArgs) of-    CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)-    CommandList _ -> throwIO (SavedArgsErrorList savedArgs)-    CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)-    CommandReadyToGo (mkFlags, _) ->-      return (mkFlags (commandDefaultFlags command))---- -------------------------------------------------------------------------------- * Exceptions--- -------------------------------------------------------------------------------data SavedArgsError-    = SavedArgsErrorHelp Args-    | SavedArgsErrorList Args-    | SavedArgsErrorOther Args [String]-  deriving (Typeable)--instance Show SavedArgsError where-  show (SavedArgsErrorHelp args) =-    "unexpected flag '--help', saved command line was:\n"-    ++ intercalate " " args-  show (SavedArgsErrorList args) =-    "unexpected flag '--list-options', saved command line was:\n"-    ++ intercalate " " args-  show (SavedArgsErrorOther args errs) =-    "saved command line was:\n"-    ++ intercalate " " args ++ "\n"-    ++ "encountered errors:\n"-    ++ intercalate "\n" errs--instance Exception SavedArgsError
− Distribution/Client/Security/DNS.hs 
@@ -1,192 +0,0 @@-{-# LANGUAGE CPP #-}--module Distribution.Client.Security.DNS-    ( queryBootstrapMirrors-    ) where--import Prelude ()-import Distribution.Client.Compat.Prelude-import Network.URI (URI(..), URIAuth(..), parseURI)-import Control.Exception (try)-import Distribution.Simple.Utils--#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)-import Network.DNS (queryTXT, Name(..), CharStr(..))-import qualified Data.ByteString.Char8 as BS.Char8-#else-import Distribution.Simple.Program.Db-         ( emptyProgramDb, addKnownProgram-         , configureAllKnownPrograms, lookupProgram )-import Distribution.Simple.Program-         ( simpleProgram-         , programInvocation-         , getProgramInvocationOutput )-#endif---- | Try to lookup RFC1464-encoded mirror urls for a Hackage--- repository url by performing a DNS TXT lookup on the--- @_mirrors.@-prefixed URL hostname.------ Example: for @http://hackage.haskell.org/@--- perform a DNS TXT query for the hostname--- @_mirrors.hackage.haskell.org@ which may look like e.g.------ > _mirrors.hackage.haskell.org. 300 IN TXT--- >    "0.urlbase=http://hackage.fpcomplete.com/"--- >    "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"------ NB: hackage-security doesn't require DNS lookups being trustworthy,--- as the trust is established via the cryptographically signed TUF--- meta-data that is retrieved from the resolved Hackage repository.--- Moreover, we already have to protect against a compromised--- @hackage.haskell.org@ DNS entry, so an the additional--- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't--- constitute a significant new attack vector anyway.----queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]--#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)--- use @resolv@ package for performing DNS queries-queryBootstrapMirrors verbosity repoUri-  | Just auth <- uriAuthority repoUri = do-         let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))--         mirrors' <- try $ do-                  txts <- queryTXT mirrorsDnsName-                  evaluate (force $ extractMirrors (map snd txts))--         mirrors <- case mirrors' of-             Left e -> do-                 warn verbosity ("Caught exception during _mirrors lookup:"++-                                 displayException (e :: SomeException))-                 return []-             Right v -> return v--         if null mirrors-         then warn verbosity ("No mirrors found for " ++ show repoUri)-         else do info verbosity ("located " ++ show (length mirrors) ++-                                 " mirrors for " ++ show repoUri ++ " :")-                 for_ mirrors $ \url -> info verbosity ("- " ++ show url)--         return mirrors--  | otherwise = return []---- | Extract list of mirrors from 'queryTXT' result-extractMirrors :: [[CharStr]] -> [URI]-extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals-  where-    vals = [ (kn,v) | CharStr e <- concat txtChunks-                    , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]-                    , Just kn <- [isUrlBase k]-                    ]-------------------------------------------------------------------------------#else /* !defined(MIN_VERSION_resolv) */--- use external method via @nslookup@-queryBootstrapMirrors verbosity repoUri-  | Just auth <- uriAuthority repoUri = do-        progdb <- configureAllKnownPrograms verbosity $-                  addKnownProgram nslookupProg emptyProgramDb--        case lookupProgram nslookupProg progdb of-          Nothing -> do-              warn verbosity "'nslookup' tool missing - can't locate mirrors"-              return []--          Just nslookup -> do-              let mirrorsDnsName = "_mirrors." ++ uriRegName auth--              mirrors' <- try $ do-                  out <- getProgramInvocationOutput verbosity $-                         programInvocation nslookup ["-query=TXT", mirrorsDnsName]-                  evaluate (force $ extractMirrors mirrorsDnsName out)--              mirrors <- case mirrors' of-                Left e -> do-                    warn verbosity ("Caught exception during _mirrors lookup:"++-                                    displayException (e :: SomeException))-                    return []-                Right v -> return v--              if null mirrors-              then warn verbosity ("No mirrors found for " ++ show repoUri)-              else do info verbosity ("located " ++ show (length mirrors) ++-                                      " mirrors for " ++ show repoUri ++ " :")-                      for_ mirrors $ \url -> info verbosity ("- " ++ show url)--              return mirrors--  | otherwise = return []-  where-    nslookupProg = simpleProgram "nslookup"---- | Extract list of mirrors from @nslookup -query=TXT@ output.-extractMirrors :: String -> String -> [URI]-extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals-  where-    vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0-                    , h == hostname-                    , e <- ents-                    , Just (k,v) <- [splitRfc1464 e]-                    , Just kn <- [isUrlBase k]-                    ]---- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly-parseNsLookupTxt :: String -> Maybe [(String,[String])]-parseNsLookupTxt = go0 [] []-  where-    -- approximate grammar:-    -- <entries> := { <entry> }-    -- (<entry> starts at begin of line, but may span multiple lines)-    -- <entry> := ^ <hostname> TAB "text =" { <qstring> }-    -- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)--    -- scan for ^ <word> <TAB> "text ="-    go0 []  _  []                                = Nothing-    go0 res _  []                                = Just (reverse res)-    go0 res _  ('\n':xs)                         = go0 res [] xs-    go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)-    go0 res lw (x:xs)                            = go0 res (x:lw) xs--    -- collect at least one <qstring>-    go1 res lw qs ('"':xs) = case qstr "" xs of-      Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')-      Nothing       -> Nothing -- bad quoting-    go1 _   _  [] _  = Nothing -- missing qstring-    go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs--    qstr _   ('\n':_) = Nothing -- We don't support unquoted LFs-    qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs-    qstr acc ('\\':'"':cs)  = qstr ('"':acc) cs-    qstr acc ('"':cs) = Just (reverse acc, cs)-    qstr acc (c:cs)   = qstr (c:acc) cs-    qstr _   []       = Nothing--#endif--------------------------------------------------------------------------------- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data-isUrlBase :: String -> Maybe Int-isUrlBase s-  | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns-  | otherwise = Nothing-  where-    ns = take (length s - 8) s---- | Split a TXT string into key and value according to RFC1464.--- Returns 'Nothing' if parsing fails.-splitRfc1464 :: String -> Maybe (String,String)-splitRfc1464 = go ""-  where-    go _ [] = Nothing-    go acc ('`':c:cs) = go (c:acc) cs-    go acc ('=':cs)   = go2 (reverse acc) "" cs-    go acc (c:cs)-      | isSpace c = go acc cs-      | otherwise = go (c:acc) cs--    go2 k acc [] = Just (k,reverse acc)-    go2 _ _   ['`'] = Nothing-    go2 k acc ('`':c:cs) = go2 k (c:acc) cs-    go2 k acc (c:cs) = go2 k (c:acc) cs
− Distribution/Client/Security/HTTP.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'-module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where--import Distribution.Solver.Compat.Prelude-import Prelude ()---- stdlibs-import System.Directory-         ( getTemporaryDirectory )-import Network.URI-         ( URI )-import qualified Data.ByteString.Lazy as BS.L-import qualified Network.HTTP         as HTTP---- Cabal/cabal-install-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Client.HttpUtils-         ( HttpTransport(..), HttpCode )-import Distribution.Client.Utils-         ( withTempFileName )---- hackage-security-import           Hackage.Security.Client.Repository.HttpLib (HttpLib (..))-import qualified Hackage.Security.Client as HC-import qualified Hackage.Security.Client.Repository.HttpLib as HC-import qualified Hackage.Security.Util.Checked as HC-import qualified Hackage.Security.Util.Pretty as HC--{--------------------------------------------------------------------------------  'HttpLib' implementation--------------------------------------------------------------------------------}---- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'------ NOTE: The match between these two APIs is currently not perfect:------ * We don't get any response headers back from the 'HttpTransport', so we---   don't know if the server supports range requests. For now we optimistically---   assume that it does.--- * The 'HttpTransport' wants to know where to place the resulting file,---   whereas the 'HttpLib' expects an 'IO' action which streams the download;---   the security library then makes sure that the file gets written to a---   location which is suitable (in particular, to a temporary file in the---   directory where the file needs to end up, so that it can "finalize" the---   file simply by doing 'renameFile'). Right now we write the file to a---   temporary file in the system temp directory here and then read it again---   to pass it to the security library; this is a problem for two reasons: it---   is a source of inefficiency; and it means that the security library cannot---   insist on a minimum download rate (potential security attack).---   Fixing it however would require changing the 'HttpTransport'.-transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib-transportAdapter verbosity getTransport = HttpLib{-      httpGet      = \headers uri callback -> do-                        transport <- getTransport-                        httpGetImpl verbosity transport headers uri callback-    , httpGetRange = \headers uri range callback -> do-                        transport <- getTransport-                        getRange verbosity transport headers uri range callback-    }--httpGetImpl-    :: HC.Throws HC.SomeRemoteError-    => Verbosity-    -> HttpTransport-    -> [HC.HttpRequestHeader] -> URI-    -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)-    -> IO a-httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do-  get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->-    case code of-      200 -> callback respHeaders br-      _   -> HC.throwChecked $ UnexpectedResponse uri code--getRange :: HC.Throws HC.SomeRemoteError-         => Verbosity-         -> HttpTransport-         -> [HC.HttpRequestHeader] -> URI -> (Int, Int)-         -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)-         -> IO a-getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do-  get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->-    case code of-       200 -> callback HC.HttpStatus200OK             respHeaders br-       206 -> callback HC.HttpStatus206PartialContent respHeaders br-       _   -> HC.throwChecked $ UnexpectedResponse uri code---- | Internal generalization of 'get' and 'getRange'-get' :: Verbosity-     -> HttpTransport-     -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int)-     -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)-     -> IO a-get' verbosity transport reqHeaders uri mRange callback = do-    tempDir <- getTemporaryDirectory-    withTempFileName tempDir "transportAdapterGet" $ \temp -> do-      (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'-      br <- HC.bodyReaderFromBS =<< BS.L.readFile temp-      callback code [HC.HttpResponseAcceptRangesBytes] br-  where-    reqHeaders' = mkReqHeaders reqHeaders mRange--{--------------------------------------------------------------------------------  Request headers--------------------------------------------------------------------------------}--mkRangeHeader :: Int -> Int -> HTTP.Header-mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader-  where-    -- Content-Range header uses inclusive rather than exclusive bounds-    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>-    rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)--mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]-mkReqHeaders reqHeaders mRange = concat [-      tr [] reqHeaders-    , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]-    ]-  where-    tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]-    tr acc [] =-      concatMap finalize acc-    tr acc (HC.HttpRequestMaxAge0:os) =-      tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os-    tr acc (HC.HttpRequestNoTransform:os) =-      tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os--    -- Some headers are comma-separated, others need multiple headers for-    -- multiple options.-    ---    -- TODO: Right we just comma-separate all of them.-    finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]-    finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))]--    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]-    insert x y = modifyAssocList x (++ y)--    -- modify the first matching element-    modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]-    modifyAssocList a f = go where-        go []                         = []-        go (p@(a', b) : xs) | a == a'   = (a', f b) : xs-                            | otherwise = p         : go xs--{--------------------------------------------------------------------------------  Custom exceptions--------------------------------------------------------------------------------}--data UnexpectedResponse = UnexpectedResponse URI Int-  deriving (Typeable)--instance HC.Pretty UnexpectedResponse where-  pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code-                                      ++ " for " ++ show uri--#if MIN_VERSION_base(4,8,0)-deriving instance Show UnexpectedResponse-instance Exception UnexpectedResponse where displayException = HC.pretty-#else-instance Show UnexpectedResponse where show = HC.pretty-instance Exception UnexpectedResponse-#endif--wrapCustomEx :: ( ( HC.Throws UnexpectedResponse-                  , HC.Throws IOException-                  ) => IO a)-             -> (HC.Throws HC.SomeRemoteError => IO a)-wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex)-                 $ HC.handleChecked (\(ex :: IOException)        -> go ex)-                 $ act-  where-    go ex = HC.throwChecked (HC.SomeRemoteError ex)
− Distribution/Client/Setup.hs 
@@ -1,2683 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE LambdaCase          #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Setup--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Setup-    ( globalCommand, GlobalFlags(..), defaultGlobalFlags-    , RepoContext(..), withRepoContext-    , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags-    , configPackageDB', configCompilerAux'-    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags-    , buildCommand, BuildFlags(..)-    , filterTestFlags-    , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions-                        , configureExOptions, reconfigureCommand-    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags-    , filterHaddockArgs, filterHaddockFlags, haddockOptions-    , defaultSolver, defaultMaxBackjumps-    , listCommand, ListFlags(..), listNeedsCompiler-    , updateCommand, UpdateFlags(..), defaultUpdateFlags-    , infoCommand, InfoFlags(..)-    , fetchCommand, FetchFlags(..)-    , freezeCommand, FreezeFlags(..)-    , genBoundsCommand-    , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..)-    , getCommand, unpackCommand, GetFlags(..)-    , checkCommand-    , formatCommand-    , uploadCommand, UploadFlags(..), IsCandidate(..)-    , reportCommand, ReportFlags(..)-    , runCommand-    , initCommand, initOptions, IT.InitFlags(..)-    , actAsSetupCommand, ActAsSetupFlags(..)-    , execCommand, ExecFlags(..), defaultExecFlags-    , userConfigCommand, UserConfigFlags(..)-    , manpageCommand-    , haddockCommand-    , cleanCommand-    , doctestCommand-    , copyCommand-    , registerCommand--    , parsePackageArgs-    , liftOptions-    , yesNoOpt-    ) where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (get)--import Distribution.Client.Types.Credentials (Username (..), Password (..))-import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..))-import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..))-import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy--import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import Distribution.Client.Dependency.Types-         ( PreSolver(..) )-import Distribution.Client.IndexUtils.ActiveRepos-         ( ActiveRepos )-import Distribution.Client.IndexUtils.IndexState-         ( TotalIndexState, headTotalIndexState )-import qualified Distribution.Client.Init.Types as IT-         ( InitFlags(..), PackageType(..), defaultInitFlags )-import Distribution.Client.Targets-         ( UserConstraint, readUserConstraint )-import Distribution.Utils.NubList-         ( NubList, toNubList, fromNubList)--import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.Settings--import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack )-import Distribution.Simple.Program (ProgramDb, defaultProgramDb)-import Distribution.Simple.Command hiding (boolOpt, boolOpt')-import qualified Distribution.Simple.Command as Command-import Distribution.Simple.Configure-       ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling )-import qualified Distribution.Simple.Setup as Cabal-import Distribution.Simple.Flag-         ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag-         , flagElim, fromFlagOrDefault-         )-import Distribution.Simple.Setup-         ( ConfigFlags(..), BuildFlags(..), ReplFlags-         , TestFlags, BenchmarkFlags-         , HaddockFlags(..)-         , CleanFlags(..), DoctestFlags(..)-         , CopyFlags(..), RegisterFlags(..)-         , readPackageDbList, showPackageDbList-         , BooleanFlag(..), optionVerbosity-         , boolOpt, boolOpt', trueArg, falseArg-         , optionNumJobs )-import Distribution.Simple.InstallDirs-         ( PathTemplate, InstallDirs(..)-         , toPathTemplate, fromPathTemplate, combinePathTemplate )-import Distribution.Version-         ( Version, mkVersion )-import Distribution.Package-         ( PackageName )-import Distribution.Types.GivenComponent-         ( GivenComponent(..) )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint(..) )-import Distribution.Types.UnqualComponentName-         ( unqualComponentNameToPackageName )-import Distribution.PackageDescription-         ( BuildType(..), RepoKind(..), LibraryName(..) )-import Distribution.System ( Platform )-import Distribution.ReadE-         ( ReadE(..), succeedReadE, parsecToReadE )-import qualified Distribution.Compat.CharParsing as P-import Distribution.Verbosity-         ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )-import Distribution.Simple.Utils-         ( wrapText )-import Distribution.Client.GlobalFlags-         ( GlobalFlags(..), defaultGlobalFlags-         , RepoContext(..), withRepoContext-         )-import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)-import Distribution.FieldGrammar.Newtypes (SpecVersion (..))--import Data.List-         ( deleteFirstsBy )-import System.FilePath-         ( (</>) )--globalCommand :: [Command action] -> CommandUI GlobalFlags-globalCommand commands = CommandUI {-    commandName         = "",-    commandSynopsis     =-         "Command line interface to the Haskell Cabal infrastructure.",-    commandUsage        = \pname ->-         "See http://www.haskell.org/cabal/ for more information.\n"-      ++ "\n"-      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",-    commandDescription  = Just $ \pname ->-      let-        commands' = commands ++ [commandAddAction helpCommandUI undefined]-        cmdDescs = getNormalCommandDescriptions commands'-        -- if new commands are added, we want them to appear even if they-        -- are not included in the custom listing below. Thus, we calculate-        -- the `otherCmds` list and append it under the `other` category.-        -- Alternatively, a new testcase could be added that ensures that-        -- the set of commands listed here is equal to the set of commands-        -- that are actually available.-        otherCmds = deleteFirstsBy (==) (map fst cmdDescs)-          [ "help"-          , "update"-          , "install"-          , "fetch"-          , "list"-          , "info"-          , "user-config"-          , "get"-          , "init"-          , "configure"-          , "build"-          , "clean"-          , "run"-          , "repl"-          , "test"-          , "bench"-          , "check"-          , "sdist"-          , "upload"-          , "report"-          , "freeze"-          , "gen-bounds"-          , "outdated"-          , "haddock"-          , "hscolour"-          , "exec"-          , "new-build"-          , "new-configure"-          , "new-repl"-          , "new-freeze"-          , "new-run"-          , "new-test"-          , "new-bench"-          , "new-haddock"-          , "new-exec"-          , "new-update"-          , "new-install"-          , "new-clean"-          , "new-sdist"-          , "list-bin"-          -- v1 commands, stateful style-          , "v1-build"-          , "v1-configure"-          , "v1-repl"-          , "v1-freeze"-          , "v1-run"-          , "v1-test"-          , "v1-bench"-          , "v1-haddock"-          , "v1-exec"-          , "v1-update"-          , "v1-install"-          , "v1-clean"-          , "v1-sdist"-          , "v1-doctest"-          , "v1-copy"-          , "v1-register"-          , "v1-reconfigure"-          -- v2 commands, nix-style-          , "v2-build"-          , "v2-configure"-          , "v2-repl"-          , "v2-freeze"-          , "v2-run"-          , "v2-test"-          , "v2-bench"-          , "v2-haddock"-          , "v2-exec"-          , "v2-update"-          , "v2-install"-          , "v2-clean"-          , "v2-sdist"-          ]-        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]-        align str = str ++ replicate (maxlen - length str) ' '-        startGroup n = " ["++n++"]"-        par          = ""-        addCmd n     = case lookup n cmdDescs of-                         Nothing -> ""-                         Just d -> "  " ++ align n ++ "    " ++ d-      in-         "Commands:\n"-      ++ unlines (-        [ startGroup "global"-        , addCmd "update"-        , addCmd "install"-        , par-        , addCmd "help"-        , addCmd "info"-        , addCmd "list"-        , addCmd "fetch"-        , addCmd "user-config"-        , par-        , startGroup "package"-        , addCmd "get"-        , addCmd "init"-        , par-        , addCmd "configure"-        , addCmd "build"-        , addCmd "clean"-        , par-        , addCmd "run"-        , addCmd "repl"-        , addCmd "test"-        , addCmd "bench"-        , par-        , addCmd "check"-        , addCmd "sdist"-        , addCmd "upload"-        , addCmd "report"-        , par-        , addCmd "freeze"-        , addCmd "gen-bounds"-        , addCmd "outdated"-        , addCmd "haddock"-        , addCmd "hscolour"-        , addCmd "exec"-        , addCmd "list-bin"-        , par-        , startGroup "new-style projects (forwards-compatible aliases)"-        , addCmd "v2-build"-        , addCmd "v2-configure"-        , addCmd "v2-repl"-        , addCmd "v2-run"-        , addCmd "v2-test"-        , addCmd "v2-bench"-        , addCmd "v2-freeze"-        , addCmd "v2-haddock"-        , addCmd "v2-exec"-        , addCmd "v2-update"-        , addCmd "v2-install"-        , addCmd "v2-clean"-        , addCmd "v2-sdist"-        , par-        , startGroup "legacy command aliases"-        , addCmd "v1-build"-        , addCmd "v1-configure"-        , addCmd "v1-repl"-        , addCmd "v1-run"-        , addCmd "v1-test"-        , addCmd "v1-bench"-        , addCmd "v1-freeze"-        , addCmd "v1-haddock"-        , addCmd "v1-exec"-        , addCmd "v1-update"-        , addCmd "v1-install"-        , addCmd "v1-clean"-        , addCmd "v1-sdist"-        , addCmd "v1-doctest"-        , addCmd "v1-copy"-        , addCmd "v1-register"-        , addCmd "v1-reconfigure"-        ] ++ if null otherCmds then [] else par-                                           :startGroup "other"-                                           :[addCmd n | n <- otherCmds])-      ++ "\n"-      ++ "For more information about a command use:\n"-      ++ "   " ++ pname ++ " COMMAND --help\n"-      ++ "or " ++ pname ++ " help COMMAND\n"-      ++ "\n"-      ++ "To install Cabal packages from hackage use:\n"-      ++ "  " ++ pname ++ " install foo [--dry-run]\n"-      ++ "\n"-      ++ "Occasionally you need to update the list of available packages:\n"-      ++ "  " ++ pname ++ " update\n",-    commandNotes = Nothing,-    commandDefaultFlags = mempty,-    commandOptions = args-  }-  where-    args :: ShowOrParseArgs -> [OptionField GlobalFlags]-    args ShowArgs  = argsShown-    args ParseArgs = argsShown ++ argsNotShown--    -- arguments we want to show in the help-    argsShown :: [OptionField GlobalFlags]-    argsShown = [-       option ['V'] ["version"]-         "Print version information"-         globalVersion (\v flags -> flags { globalVersion = v })-         trueArg--      ,option [] ["numeric-version"]-         "Print just the version number"-         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })-         trueArg--      ,option [] ["config-file"]-         "Set an alternate location for the config file"-         globalConfigFile (\v flags -> flags { globalConfigFile = v })-         (reqArgFlag "FILE")--      ,option [] ["default-user-config"]-         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."-         globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})-         (reqArgFlag "FILE")--      ,option [] ["ignore-expiry"]-         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"-         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })-         trueArg--      ,option [] ["http-transport"]-         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"-         globalHttpTransport (\v flags -> flags { globalHttpTransport = v })-         (reqArgFlag "HttpTransport")-      ,option [] ["nix"]-         "Nix integration: run commands through nix-shell if a 'shell.nix' file exists"-         globalNix (\v flags -> flags { globalNix = v })-         (boolOpt [] [])--      ]--    -- arguments we don't want shown in the help-    argsNotShown :: [OptionField GlobalFlags]-    argsNotShown = [-       option [] ["remote-repo"]-         "The name and url for a remote repository"-         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })-         (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList))--      ,option [] ["local-no-index-repo"]-         "The name and a path for a local no-index repository"-         globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v })-         (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList))--      ,option [] ["remote-repo-cache"]-         "The location where downloads from all remote repos are cached"-         globalCacheDir (\v flags -> flags { globalCacheDir = v })-         (reqArgFlag "DIR")--      ,option [] ["logs-dir", "logsdir"]-         "The location to put log files"-         globalLogsDir (\v flags -> flags { globalLogsDir = v })-         (reqArgFlag "DIR")--      ,option [] ["world-file"]-         "The location of the world file"-         globalWorldFile (\v flags -> flags { globalWorldFile = v })-         (reqArgFlag "FILE")--      ,option [] ["store-dir", "storedir"]-         "The location of the nix-local-build store"-         globalStoreDir (\v flags -> flags { globalStoreDir = v })-         (reqArgFlag "DIR")--      , option [] ["active-repositories"]-         "The active package repositories"-         globalActiveRepos (\v flags ->  flags { globalActiveRepos = v })-         (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)-                                        (toFlag `fmap` parsec))-                         (map prettyShow . flagToList))-      ]---- --------------------------------------------------------------- * Config flags--- --------------------------------------------------------------configureCommand :: CommandUI ConfigFlags-configureCommand = c-  { commandName         = "configure"-  , commandDefaultFlags = mempty-  , commandDescription  = Just $ \_ -> wrapText $-         "Configure how the package is built by setting "-      ++ "package (and other) flags.\n"-      ++ "\n"-      ++ "The configuration affects several other commands, "-      ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n"-  , commandUsage        = \pname ->-    "Usage: " ++ pname ++ " v1-configure [FLAGS]\n"-  , commandNotes = Just $ \pname ->-    (Cabal.programFlagsDescription defaultProgramDb ++ "\n")-      ++ "Examples:\n"-      ++ "  " ++ pname ++ " v1-configure\n"-      ++ "    Configure with defaults;\n"-      ++ "  " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n"-      ++ "    Configure building package including tests,\n"-      ++ "    with some package-specific flag.\n"-  }- where-  c = Cabal.configureCommand defaultProgramDb--configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]-configureOptions = commandOptions configureCommand---- | Given some 'ConfigFlags' for the version of Cabal that--- cabal-install was built with, and a target older 'Version' of--- Cabal that we want to pass these flags to, convert the--- flags into a form that will be accepted by the older--- Setup script.  Generally speaking, this just means filtering--- out flags that the old Cabal library doesn't understand, but--- in some cases it may also mean "emulating" a feature using--- some more legacy flags.-filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags-filterConfigureFlags flags cabalLibVersion-  -- NB: we expect the latest version to be the most common case,-  -- so test it first.-  | cabalLibVersion >= mkVersion [2,5,0]  = flags_latest-  -- The naming convention is that flags_version gives flags with-  -- all flags *introduced* in version eliminated.-  -- It is NOT the latest version of Cabal library that-  -- these flags work for; version of introduction is a more-  -- natural metric.-  | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10-  | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0-  | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0-  | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0-  | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0-  | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1-  | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2-  | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1-  | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0-  | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1-  | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0-  | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0-  | cabalLibVersion < mkVersion [2,1,0]  = flags_2_1_0-  | cabalLibVersion < mkVersion [2,5,0]  = flags_2_5_0-  | otherwise = error "the impossible just happened" -- see first guard-  where-    flags_latest = flags        {-      -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.-      -- Note: this is not in the wrong place. configConstraints gets-      -- repopulated in flags_1_19_1 but it needs to be set to empty for-      -- newer versions first.-      configConstraints = []-      }--    flags_2_5_0 = flags_latest {-      -- Cabal < 2.5 does not understand --dependency=pkg:component=cid-      -- (public sublibraries), so we convert it to the legacy-      -- --dependency=pkg_or_internal_compoent=cid-        configDependencies =-          let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) =-                Just $ GivenComponent-                       (unqualComponentNameToPackageName cn)-                       LMainLibName-                       cid-              convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =-                Just $ GivenComponent pn LMainLibName cid-          in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags-        -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.-      , configAllowDependingOnPrivateLibs = NoFlag-        -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.-      , configFullyStaticExe = NoFlag-      }--    flags_2_1_0 = flags_2_5_0 {-      -- Cabal < 2.1 doesn't know about -v +timestamp modifier-        configVerbosity   = fmap verboseNoTimestamp (configVerbosity flags_latest)-      -- Cabal < 2.1 doesn't know about --<enable|disable>-static-      , configStaticLib   = NoFlag-      , configSplitSections = NoFlag-      }--    flags_1_25_0 = flags_2_1_0 {-      -- Cabal < 1.25.0 doesn't know about --dynlibdir.-      configInstallDirs = configInstallDirs_1_25_0,-      -- Cabal < 1.25 doesn't have extended verbosity syntax-      configVerbosity   = fmap verboseNoFlags (configVerbosity flags_2_1_0),-      -- Cabal < 1.25 doesn't support --deterministic-      configDeterministic = mempty-      }-    configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in-        dirs { dynlibdir = NoFlag-             , libexecsubdir = NoFlag-             , libexecdir = maybeToFlag $-                 combinePathTemplate <$> flagToMaybe (libexecdir dirs)-                                     <*> flagToMaybe (libexecsubdir dirs)-             }-    -- Cabal < 1.23 doesn't know about '--profiling-detail'.-    -- Cabal < 1.23 has a hacked up version of 'enable-profiling'-    -- which we shouldn't use.-    (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags-    flags_1_23_0 = flags_1_25_0 { configProfDetail    = NoFlag-                                , configProfLibDetail = NoFlag-                                , configIPID          = NoFlag-                                , configProf          = NoFlag-                                , configProfExe       = Flag tryExeProfiling-                                , configProfLib       = Flag tryLibProfiling-                                }--    -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d)-    -- due to temporary amnesia of the --*-executable-profiling flags-    flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag-                                , configProfExe   = NoFlag-                                }--    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.-    flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag }--    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'-    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'-    -- (but we already dealt with it in flags_1_23_0)-    flags_1_21_1 =-      flags_1_22_0 { configRelocatable = NoFlag-                   , configCoverage = NoFlag-                   , configLibCoverage = configCoverage flags-                   }-    -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and-    -- '--enable-library-stripping'.-    flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag-                                , configStripLibs = NoFlag }-    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.-    flags_1_19_1 = flags_1_19_2 { configDependencies = []-                                , configConstraints  = configConstraints flags }-    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.-    flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList []-                                , configInstallDirs = configInstallDirs_1_18_0}-    configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag }-    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.-    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }-    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'-    -- and '--enable/disable-library-coverage'.-    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag-                                , configDynExe      = NoFlag }-    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.-    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }-    -- Cabal < 1.3.10 does not grok the '--constraints' flag.-    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }---- | Get the package database settings from 'ConfigFlags', accounting for--- @--package-db@ and @--user@ flags.-configPackageDB' :: ConfigFlags -> PackageDBStack-configPackageDB' cfg =-    interpretPackageDbFlags userInstall (configPackageDBs cfg)-  where-    userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg)---- | Configure the compiler, but reduce verbosity during this step.-configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb)-configCompilerAux' configFlags =-  configCompilerAuxEx configFlags-    --FIXME: make configCompilerAux use a sensible verbosity-    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }---- --------------------------------------------------------------- * Config extra flags--- ---------------------------------------------------------------- | cabal configure takes some extra flags beyond runghc Setup configure----data ConfigExFlags = ConfigExFlags {-    configCabalVersion  :: Flag Version,-    configExConstraints :: [(UserConstraint, ConstraintSource)],-    configPreferences   :: [PackageVersionConstraint],-    configSolver        :: Flag PreSolver,-    configAllowNewer    :: Maybe AllowNewer,-    configAllowOlder    :: Maybe AllowOlder,-    configWriteGhcEnvironmentFilesPolicy-      :: Flag WriteGhcEnvironmentFilesPolicy-  }-  deriving (Eq, Show, Generic)--defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }--configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)-configureExCommand = configureCommand {-    commandDefaultFlags = (mempty, defaultConfigExFlags),-    commandOptions      = \showOrParseArgs ->-         liftOptions fst setFst-         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])-                  . optionName) $ configureOptions  showOrParseArgs)-      ++ liftOptions snd setSnd-         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)-  }-  where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)--configureExOptions :: ShowOrParseArgs-                   -> ConstraintSource-                   -> [OptionField ConfigExFlags]-configureExOptions _showOrParseArgs src =-  [ option [] ["cabal-lib-version"]-      ("Select which version of the Cabal lib to use to build packages "-      ++ "(useful for testing).")-      configCabalVersion (\v flags -> flags { configCabalVersion = v })-      (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++)-                                    (fmap toFlag parsec))-                        (map prettyShow. flagToList))-  , option [] ["constraint"]-      "Specify constraints on a package (version, installed/source, flags)"-      configExConstraints (\v flags -> flags { configExConstraints = v })-      (reqArg "CONSTRAINT"-              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)-              (map $ prettyShow . fst))--  , option [] ["preference"]-      "Specify preferences (soft constraints) on the version of a package"-      configPreferences (\v flags -> flags { configPreferences = v })-      (reqArg "CONSTRAINT"-              (parsecToReadE (const "dependency expected")-                          (fmap (\x -> [x]) parsec))-              (map prettyShow))--  , optionSolver configSolver (\v flags -> flags { configSolver = v })--  , option [] ["allow-older"]-    ("Ignore lower bounds in all dependencies or DEPS")-    (fmap unAllowOlder . configAllowOlder)-    (\v flags -> flags { configAllowOlder = fmap AllowOlder v})-    (optArg "DEPS"-     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)-     (Just RelaxDepsAll) relaxDepsPrinter)--  , option [] ["allow-newer"]-    ("Ignore upper bounds in all dependencies or DEPS")-    (fmap unAllowNewer . configAllowNewer)-    (\v flags -> flags { configAllowNewer = fmap AllowNewer v})-    (optArg "DEPS"-     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)-     (Just RelaxDepsAll) relaxDepsPrinter)--  , option [] ["write-ghc-environment-files"]-    ("Whether to create a .ghc.environment file after a successful build"-      ++ " (v2-build only)")-    configWriteGhcEnvironmentFilesPolicy-    (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v})-    (reqArg "always|never|ghc8.4.4+"-     writeGhcEnvironmentFilesPolicyParser-     writeGhcEnvironmentFilesPolicyPrinter)-  ]---writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy)-writeGhcEnvironmentFilesPolicyParser = ReadE $ \case-  "always"    -> Right $ Flag AlwaysWriteGhcEnvironmentFiles-  "never"     -> Right $ Flag NeverWriteGhcEnvironmentFiles-  "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer-  policy      -> Left  $ "Cannot parse the GHC environment file write policy '"-                 <> policy <> "'"--writeGhcEnvironmentFilesPolicyPrinter-  :: Flag WriteGhcEnvironmentFilesPolicy -> [String]-writeGhcEnvironmentFilesPolicyPrinter = \case-  (Flag AlwaysWriteGhcEnvironmentFiles)                -> ["always"]-  (Flag NeverWriteGhcEnvironmentFiles)                 -> ["never"]-  (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"]-  NoFlag                                               -> []---relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps)-relaxDepsParser =-  (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',')--relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]-relaxDepsPrinter Nothing                     = []-relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]-relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs---instance Monoid ConfigExFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ConfigExFlags where-  (<>) = gmappend--reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags)-reconfigureCommand-  = configureExCommand-    { commandName         = "reconfigure"-    , commandSynopsis     = "Reconfigure the package if necessary."-    , commandDescription  = Just $ \pname -> wrapText $-         "Run `configure` with the most recently used flags, or append FLAGS "-         ++ "to the most recently used configuration. "-         ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. "-         ++ "If the package has never been configured, the default flags are "-         ++ "used."-    , commandNotes        = Just $ \pname ->-        "Examples:\n"-        ++ "  " ++ pname ++ " v1-reconfigure\n"-        ++ "    Configure with the most recently used flags.\n"-        ++ "  " ++ pname ++ " v1-reconfigure -w PATH\n"-        ++ "    Reconfigure with the most recently used flags,\n"-        ++ "    but use the compiler at PATH.\n\n"-    , commandUsage        = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ]-    , commandDefaultFlags = mempty-    }---- --------------------------------------------------------------- * Build flags--- --------------------------------------------------------------buildCommand :: CommandUI BuildFlags-buildCommand = parent {-    commandName = "build",-    commandDescription  = Just $ \_ -> wrapText $-      "Components encompass executables, tests, and benchmarks.\n"-        ++ "\n"-        ++ "Affected by configuration options, see `v1-configure`.\n",-    commandDefaultFlags = commandDefaultFlags parent,-    commandUsage        = usageAlternatives "v1-build" $-      [ "[FLAGS]", "COMPONENTS [FLAGS]" ],-    commandOptions      = commandOptions parent-    , commandNotes      = Just $ \pname ->-      "Examples:\n"-        ++ "  " ++ pname ++ " v1-build           "-        ++ "    All the components in the package\n"-        ++ "  " ++ pname ++ " v1-build foo       "-        ++ "    A component (i.e. lib, exe, test suite)\n\n"-        ++ Cabal.programFlagsDescription defaultProgramDb-  }-  where-    parent = Cabal.buildCommand defaultProgramDb---- --------------------------------------------------------------- * Test flags--- ---------------------------------------------------------------- | Given some 'TestFlags' for the version of Cabal that--- cabal-install was built with, and a target older 'Version' of--- Cabal that we want to pass these flags to, convert the--- flags into a form that will be accepted by the older--- Setup script.  Generally speaking, this just means filtering--- out flags that the old Cabal library doesn't understand, but--- in some cases it may also mean "emulating" a feature using--- some more legacy flags.-filterTestFlags :: TestFlags -> Version -> TestFlags-filterTestFlags flags cabalLibVersion-  -- NB: we expect the latest version to be the most common case,-  -- so test it first.-  | cabalLibVersion >= mkVersion [3,0,0] = flags_latest-  -- The naming convention is that flags_version gives flags with-  -- all flags *introduced* in version eliminated.-  -- It is NOT the latest version of Cabal library that-  -- these flags work for; version of introduction is a more-  -- natural metric.-  | cabalLibVersion <  mkVersion [3,0,0] = flags_3_0_0-  | otherwise = error "the impossible just happened" -- see first guard-  where-    flags_latest = flags-    flags_3_0_0  = flags_latest {-      -- Cabal < 3.0 doesn't know about --test-wrapper-      Cabal.testWrapper = NoFlag-      }---- --------------------------------------------------------------- * Repl command--- --------------------------------------------------------------replCommand :: CommandUI ReplFlags-replCommand = parent {-    commandName = "repl",-    commandDescription  = Just $ \pname -> wrapText $-         "If the current directory contains no package, ignores COMPONENT "-      ++ "parameters and opens an interactive interpreter session;\n"-      ++ "\n"-      ++ "Otherwise, (re)configures with the given or default flags, and "-      ++ "loads the interpreter with the relevant modules. For executables, "-      ++ "tests and benchmarks, loads the main module (and its "-      ++ "dependencies); for libraries all exposed/other modules.\n"-      ++ "\n"-      ++ "The default component is the library itself, or the executable "-      ++ "if that is the only component.\n"-      ++ "\n"-      ++ "Support for loading specific modules is planned but not "-      ++ "implemented yet. For certain scenarios, `" ++ pname-      ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will "-      ++ "not (re)configure and you will have to specify the location of "-      ++ "other modules, if required.\n",-    commandUsage =  \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n",-    commandDefaultFlags = commandDefaultFlags parent,-    commandOptions      = commandOptions parent,-    commandNotes        = Just $ \pname ->-      "Examples:\n"-    ++ "  " ++ pname ++ " v1-repl           "-    ++ "    The first component in the package\n"-    ++ "  " ++ pname ++ " v1-repl foo       "-    ++ "    A named component (i.e. lib, exe, test suite)\n"-    ++ "  " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\""-    ++ "  Specifying flags for interpreter\n"-  }-  where-    parent = Cabal.replCommand defaultProgramDb---- --------------------------------------------------------------- * Test command--- --------------------------------------------------------------testCommand :: CommandUI (BuildFlags, TestFlags)-testCommand = parent {-  commandName = "test",-  commandDescription  = Just $ \pname -> wrapText $-         "If necessary (re)configures with `--enable-tests` flag and builds"-      ++ " the test suite.\n"-      ++ "\n"-      ++ "Remember that the tests' dependencies must be installed if there"-      ++ " are additional ones; e.g. with `" ++ pname-      ++ " v1-install --only-dependencies --enable-tests`.\n"-      ++ "\n"-      ++ "By defining UserHooks in a custom Setup.hs, the package can"-      ++ " define actions to be executed before and after running tests.\n",-  commandUsage = usageAlternatives "v1-test"-      [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ],-  commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),-  commandOptions      =-    \showOrParseArgs -> liftOptions get1 set1-                        (Cabal.buildOptions progDb showOrParseArgs)-                        ++-                        liftOptions get2 set2-                        (commandOptions parent showOrParseArgs)-  }-  where-    get1 (a,_) = a; set1 a (_,b) = (a,b)-    get2 (_,b) = b; set2 b (a,_) = (a,b)--    parent = Cabal.testCommand-    progDb = defaultProgramDb---- --------------------------------------------------------------- * Bench command--- --------------------------------------------------------------benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags)-benchmarkCommand = parent {-  commandName = "bench",-  commandUsage = usageAlternatives "v1-bench"-      [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ],-  commandDescription  = Just $ \pname -> wrapText $-         "If necessary (re)configures with `--enable-benchmarks` flag and"-      ++ " builds the benchmarks.\n"-      ++ "\n"-      ++ "Remember that the benchmarks' dependencies must be installed if"-      ++ " there are additional ones; e.g. with `" ++ pname-      ++ " v1-install --only-dependencies --enable-benchmarks`.\n"-      ++ "\n"-      ++ "By defining UserHooks in a custom Setup.hs, the package can"-      ++ " define actions to be executed before and after running"-      ++ " benchmarks.\n",-  commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),-  commandOptions      =-    \showOrParseArgs -> liftOptions get1 set1-                        (Cabal.buildOptions progDb showOrParseArgs)-                        ++-                        liftOptions get2 set2-                        (commandOptions parent showOrParseArgs)-  }-  where-    get1 (a,_) = a; set1 a (_,b) = (a,b)-    get2 (_,b) = b; set2 b (a,_) = (a,b)--    parent = Cabal.benchmarkCommand-    progDb = defaultProgramDb---- --------------------------------------------------------------- * Fetch command--- --------------------------------------------------------------data FetchFlags = FetchFlags {---    fetchOutput    :: Flag FilePath,-      fetchDeps      :: Flag Bool,-      fetchDryRun    :: Flag Bool,-      fetchSolver           :: Flag PreSolver,-      fetchMaxBackjumps     :: Flag Int,-      fetchReorderGoals     :: Flag ReorderGoals,-      fetchCountConflicts   :: Flag CountConflicts,-      fetchFineGrainedConflicts :: Flag FineGrainedConflicts,-      fetchMinimizeConflictSet :: Flag MinimizeConflictSet,-      fetchIndependentGoals :: Flag IndependentGoals,-      fetchShadowPkgs       :: Flag ShadowPkgs,-      fetchStrongFlags      :: Flag StrongFlags,-      fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls,-      fetchOnlyConstrained  :: Flag OnlyConstrained,-      fetchTests            :: Flag Bool,-      fetchBenchmarks       :: Flag Bool,-      fetchVerbosity :: Flag Verbosity-    }--defaultFetchFlags :: FetchFlags-defaultFetchFlags = FetchFlags {---  fetchOutput    = mempty,-    fetchDeps      = toFlag True,-    fetchDryRun    = toFlag False,-    fetchSolver           = Flag defaultSolver,-    fetchMaxBackjumps     = Flag defaultMaxBackjumps,-    fetchReorderGoals     = Flag (ReorderGoals False),-    fetchCountConflicts   = Flag (CountConflicts True),-    fetchFineGrainedConflicts = Flag (FineGrainedConflicts True),-    fetchMinimizeConflictSet = Flag (MinimizeConflictSet False),-    fetchIndependentGoals = Flag (IndependentGoals False),-    fetchShadowPkgs       = Flag (ShadowPkgs False),-    fetchStrongFlags      = Flag (StrongFlags False),-    fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False),-    fetchOnlyConstrained  = Flag OnlyConstrainedNone,-    fetchTests            = toFlag False,-    fetchBenchmarks       = toFlag False,-    fetchVerbosity = toFlag normal-   }--fetchCommand :: CommandUI FetchFlags-fetchCommand = CommandUI {-    commandName         = "fetch",-    commandSynopsis     = "Downloads packages for later installation.",-    commandUsage        = usageAlternatives "fetch" [ "[FLAGS] PACKAGES"-                                                    ],-    commandDescription  = Just $ \_ ->-          "Note that it currently is not possible to fetch the dependencies for a\n"-       ++ "package in the current directory.\n",-    commandNotes        = Nothing,-    commandDefaultFlags = defaultFetchFlags,-    commandOptions      = \ showOrParseArgs -> [-         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })----     , option "o" ["output"]---         "Put the package(s) somewhere specific rather than the usual cache."---         fetchOutput (\v flags -> flags { fetchOutput = v })---         (reqArgFlag "PATH")--       , option [] ["dependencies", "deps"]-           "Resolve and fetch dependencies (default)"-           fetchDeps (\v flags -> flags { fetchDeps = v })-           trueArg--       , option [] ["no-dependencies", "no-deps"]-           "Ignore dependencies"-           fetchDeps (\v flags -> flags { fetchDeps = v })-           falseArg--       , option [] ["dry-run"]-           "Do not install anything, only print what would be installed."-           fetchDryRun (\v flags -> flags { fetchDryRun = v })-           trueArg--      , option "" ["tests"]-         "dependency checking and compilation for test suites listed in the package description file."-         fetchTests (\v flags -> flags { fetchTests = v })-         (boolOpt [] [])--      , option "" ["benchmarks"]-         "dependency checking and compilation for benchmarks listed in the package description file."-         fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v })-         (boolOpt [] [])--       ] ++--       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :-       optionSolverFlags showOrParseArgs-                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })-                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })-                         fetchCountConflicts   (\v flags -> flags { fetchCountConflicts   = v })-                         fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v })-                         fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v })-                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })-                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })-                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })-                         fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v })-                         fetchOnlyConstrained  (\v flags -> flags { fetchOnlyConstrained  = v })--  }---- --------------------------------------------------------------- * Freeze command--- --------------------------------------------------------------data FreezeFlags = FreezeFlags {-      freezeDryRun           :: Flag Bool,-      freezeTests            :: Flag Bool,-      freezeBenchmarks       :: Flag Bool,-      freezeSolver           :: Flag PreSolver,-      freezeMaxBackjumps     :: Flag Int,-      freezeReorderGoals     :: Flag ReorderGoals,-      freezeCountConflicts   :: Flag CountConflicts,-      freezeFineGrainedConflicts :: Flag FineGrainedConflicts,-      freezeMinimizeConflictSet :: Flag MinimizeConflictSet,-      freezeIndependentGoals :: Flag IndependentGoals,-      freezeShadowPkgs       :: Flag ShadowPkgs,-      freezeStrongFlags      :: Flag StrongFlags,-      freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls,-      freezeOnlyConstrained  :: Flag OnlyConstrained,-      freezeVerbosity        :: Flag Verbosity-    }--defaultFreezeFlags :: FreezeFlags-defaultFreezeFlags = FreezeFlags {-    freezeDryRun           = toFlag False,-    freezeTests            = toFlag False,-    freezeBenchmarks       = toFlag False,-    freezeSolver           = Flag defaultSolver,-    freezeMaxBackjumps     = Flag defaultMaxBackjumps,-    freezeReorderGoals     = Flag (ReorderGoals False),-    freezeCountConflicts   = Flag (CountConflicts True),-    freezeFineGrainedConflicts = Flag (FineGrainedConflicts True),-    freezeMinimizeConflictSet = Flag (MinimizeConflictSet False),-    freezeIndependentGoals = Flag (IndependentGoals False),-    freezeShadowPkgs       = Flag (ShadowPkgs False),-    freezeStrongFlags      = Flag (StrongFlags False),-    freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False),-    freezeOnlyConstrained  = Flag OnlyConstrainedNone,-    freezeVerbosity        = toFlag normal-   }--freezeCommand :: CommandUI FreezeFlags-freezeCommand = CommandUI {-    commandName         = "freeze",-    commandSynopsis     = "Freeze dependencies.",-    commandDescription  = Just $ \_ -> wrapText $-         "Calculates a valid set of dependencies and their exact versions. "-      ++ "If successful, saves the result to the file `cabal.config`.\n"-      ++ "\n"-      ++ "The package versions specified in `cabal.config` will be used for "-      ++ "any future installs.\n"-      ++ "\n"-      ++ "An existing `cabal.config` is ignored and overwritten.\n",-    commandNotes        = Nothing,-    commandUsage        = usageFlags "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--       , option [] ["tests"]-           ("freezing of the dependencies of any tests suites "-            ++ "in the package description file.")-           freezeTests (\v flags -> flags { freezeTests = v })-           (boolOpt [] [])--       , option [] ["benchmarks"]-           ("freezing of the dependencies of any benchmarks suites "-            ++ "in the package description file.")-           freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v })-           (boolOpt [] [])--       ] ++--       optionSolver-         freezeSolver           (\v flags -> flags { freezeSolver           = v }):-       optionSolverFlags showOrParseArgs-                         freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })-                         freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })-                         freezeCountConflicts   (\v flags -> flags { freezeCountConflicts   = v })-                         freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v })-                         freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v })-                         freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })-                         freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })-                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })-                         freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v })-                         freezeOnlyConstrained  (\v flags -> flags { freezeOnlyConstrained  = v })--  }---- --------------------------------------------------------------- * 'gen-bounds' command--- --------------------------------------------------------------genBoundsCommand :: CommandUI FreezeFlags-genBoundsCommand = CommandUI {-    commandName         = "gen-bounds",-    commandSynopsis     = "Generate dependency bounds.",-    commandDescription  = Just $ \_ -> wrapText $-         "Generates bounds for all dependencies that do not currently have them. "-      ++ "Generated bounds are printed to stdout.  "-      ++ "You can then paste them into your .cabal file.\n"-      ++ "\n",-    commandNotes        = Nothing,-    commandUsage        = usageFlags "gen-bounds",-    commandDefaultFlags = defaultFreezeFlags,-    commandOptions      = \ _ -> [-     optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })-     ]-  }---- --------------------------------------------------------------- * 'outdated' command--- --------------------------------------------------------------data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone-                             | IgnoreMajorVersionBumpsAll-                             | IgnoreMajorVersionBumpsSome [PackageName]--instance Monoid IgnoreMajorVersionBumps where-  mempty  = IgnoreMajorVersionBumpsNone-  mappend = (<>)--instance Semigroup IgnoreMajorVersionBumps where-  IgnoreMajorVersionBumpsNone       <> r                               = r-  l@IgnoreMajorVersionBumpsAll      <> _                               = l-  l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone     = l-  (IgnoreMajorVersionBumpsSome   _) <> r@IgnoreMajorVersionBumpsAll    = r-  (IgnoreMajorVersionBumpsSome   a) <> (IgnoreMajorVersionBumpsSome b) =-    IgnoreMajorVersionBumpsSome (a ++ b)--data OutdatedFlags = OutdatedFlags {-  outdatedVerbosity     :: Flag Verbosity,-  outdatedFreezeFile    :: Flag Bool,-  outdatedNewFreezeFile :: Flag Bool,-  outdatedProjectFile   :: Flag FilePath,-  outdatedSimpleOutput  :: Flag Bool,-  outdatedExitCode      :: Flag Bool,-  outdatedQuiet         :: Flag Bool,-  outdatedIgnore        :: [PackageName],-  outdatedMinor         :: Maybe IgnoreMajorVersionBumps-  }--defaultOutdatedFlags :: OutdatedFlags-defaultOutdatedFlags = OutdatedFlags {-  outdatedVerbosity     = toFlag normal,-  outdatedFreezeFile    = mempty,-  outdatedNewFreezeFile = mempty,-  outdatedProjectFile   = mempty,-  outdatedSimpleOutput  = mempty,-  outdatedExitCode      = mempty,-  outdatedQuiet         = mempty,-  outdatedIgnore        = mempty,-  outdatedMinor         = mempty-  }--outdatedCommand :: CommandUI OutdatedFlags-outdatedCommand = CommandUI {-  commandName = "outdated",-  commandSynopsis = "Check for outdated dependencies",-  commandDescription  = Just $ \_ -> wrapText $-    "Checks for outdated dependencies in the package description file "-    ++ "or freeze file",-  commandNotes = Nothing,-  commandUsage = usageFlags "outdated",-  commandDefaultFlags = defaultOutdatedFlags,-  commandOptions      = \ _ -> [-    optionVerbosity outdatedVerbosity-      (\v flags -> flags { outdatedVerbosity = v })--    ,option [] ["freeze-file", "v1-freeze-file"]-     "Act on the freeze file"-     outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v })-     trueArg--    ,option [] ["v2-freeze-file", "new-freeze-file"]-     "Act on the new-style freeze file (default: cabal.project.freeze)"-     outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v })-     trueArg--    ,option [] ["project-file"]-     "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze"-     outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v })-     (reqArgFlag "PROJECTFILE")--    ,option [] ["simple-output"]-     "Only print names of outdated dependencies, one per line"-     outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v })-     trueArg--    ,option [] ["exit-code"]-     "Exit with non-zero when there are outdated dependencies"-     outdatedExitCode (\v flags -> flags { outdatedExitCode = v })-     trueArg--    ,option ['q'] ["quiet"]-     "Don't print any output. Implies '--exit-code' and '-v0'"-     outdatedQuiet (\v flags -> flags { outdatedQuiet = v })-     trueArg--   ,option [] ["ignore"]-    "Packages to ignore"-    outdatedIgnore (\v flags -> flags { outdatedIgnore = v })-    (reqArg "PKGS" pkgNameListParser (map prettyShow))--   ,option [] ["minor"]-    "Ignore major version bumps for these packages"-    outdatedMinor (\v flags -> flags { outdatedMinor = v })-    (optArg "PKGS" ignoreMajorVersionBumpsParser-      (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter)-   ]-  }-  where-    ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps)-                                   -> [Maybe String]-    ignoreMajorVersionBumpsPrinter Nothing = []-    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []-    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]-    ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =-      map (Just . prettyShow) $ pkgs--    ignoreMajorVersionBumpsParser  =-      (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser--    pkgNameListParser = parsecToReadE-      ("Couldn't parse the list of package names: " ++)-      (fmap toList (P.sepByNonEmpty parsec (P.char ',')))---- --------------------------------------------------------------- * Update command--- --------------------------------------------------------------data UpdateFlags-    = UpdateFlags {-        updateVerbosity  :: Flag Verbosity,-        updateIndexState :: Flag TotalIndexState-    } deriving Generic--defaultUpdateFlags :: UpdateFlags-defaultUpdateFlags-    = UpdateFlags {-        updateVerbosity  = toFlag normal,-        updateIndexState = toFlag headTotalIndexState-    }--updateCommand  :: CommandUI UpdateFlags-updateCommand = CommandUI {-    commandName         = "update",-    commandSynopsis     = "Updates list of known packages.",-    commandDescription  = Just $ \_ ->-      "For all known remote repositories, download the package list.\n",-    commandNotes        = Just $ \_ ->-      relevantConfigValuesText ["remote-repo"-                               ,"remote-repo-cache"-                               ,"local-repo"],-    commandUsage        = usageFlags "v1-update",-    commandDefaultFlags = defaultUpdateFlags,-    commandOptions      = \_ -> [-        optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }),-        option [] ["index-state"]-          ("Update the source package index to its state as it existed at a previous time. " ++-           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++-           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")-          updateIndexState (\v flags -> flags { updateIndexState = v })-          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " ++-                                       "unix-timestamps (e.g. '@1474732068'), " ++-                                       "a ISO8601 UTC timestamp " ++-                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")-                                      (toFlag `fmap` parsec))-                          (flagToList . fmap prettyShow))-    ]-  }---- --------------------------------------------------------------- * Other commands--- --------------------------------------------------------------cleanCommand :: CommandUI CleanFlags-cleanCommand = Cabal.cleanCommand-  { commandUsage = \pname ->-    "Usage: " ++ pname ++ " v1-clean [FLAGS]\n"-  }--checkCommand  :: CommandUI (Flag Verbosity)-checkCommand = CommandUI {-    commandName         = "check",-    commandSynopsis     = "Check the package for common mistakes.",-    commandDescription  = Just $ \_ -> wrapText $-         "Expects a .cabal package file in the current directory.\n"-      ++ "\n"-      ++ "The checks correspond to the requirements to packages on Hackage. "-      ++ "If no errors and warnings are reported, Hackage will accept this "-      ++ "package.\n",-    commandNotes        = Nothing,-    commandUsage        = usageFlags "check",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]-  }--formatCommand  :: CommandUI (Flag Verbosity)-formatCommand = CommandUI {-    commandName         = "format",-    commandSynopsis     = "Reformat the .cabal file using the standard style.",-    commandDescription  = Nothing,-    commandNotes        = Nothing,-    commandUsage        = usageAlternatives "format" ["[FILE]"],-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> []-  }--manpageCommand :: CommandUI ManpageFlags-manpageCommand = CommandUI {-    commandName         = "man",-    commandSynopsis     = "Outputs manpage source.",-    commandDescription  = Just $ \_ ->-      "Output manpage source to STDOUT.\n",-    commandNotes        = Nothing,-    commandUsage        = usageFlags "man",-    commandDefaultFlags = defaultManpageFlags,-    commandOptions      = manpageOptions-  }--runCommand :: CommandUI BuildFlags-runCommand = CommandUI {-    commandName         = "run",-    commandSynopsis     = "Builds and runs an executable.",-    commandDescription  = Just $ \pname -> wrapText $-         "Builds and then runs the specified executable. If no executable is "-      ++ "specified, but the package contains just one executable, that one "-      ++ "is built and executed.\n"-      ++ "\n"-      ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a "-      ++ "test-suite and get its full output.\n",-    commandNotes        = Just $ \pname ->-          "Examples:\n"-       ++ "  " ++ pname ++ " v1-run\n"-       ++ "    Run the only executable in the current package;\n"-       ++ "  " ++ pname ++ " v1-run foo -- --fooflag\n"-       ++ "    Works similar to `./foo --fooflag`.\n",-    commandUsage        = usageAlternatives "v1-run"-        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],-    commandDefaultFlags = mempty,-    commandOptions      = commandOptions parent-  }-  where-    parent = Cabal.buildCommand defaultProgramDb---- --------------------------------------------------------------- * Report flags--- --------------------------------------------------------------data ReportFlags = ReportFlags {-    reportUsername  :: Flag Username,-    reportPassword  :: Flag Password,-    reportVerbosity :: Flag Verbosity-  } deriving Generic--defaultReportFlags :: ReportFlags-defaultReportFlags = ReportFlags {-    reportUsername  = mempty,-    reportPassword  = mempty,-    reportVerbosity = toFlag normal-  }--reportCommand :: CommandUI ReportFlags-reportCommand = CommandUI {-    commandName         = "report",-    commandSynopsis     = "Upload build reports to a remote server.",-    commandDescription  = Nothing,-    commandNotes        = Just $ \_ ->-         "You can store your Hackage login in the ~/.cabal/config file\n",-    commandUsage        = usageAlternatives "report" ["[FLAGS]"],-    commandDefaultFlags = defaultReportFlags,-    commandOptions      = \_ ->-      [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })--      ,option ['u'] ["username"]-        "Hackage username."-        reportUsername (\v flags -> flags { reportUsername = v })-        (reqArg' "USERNAME" (toFlag . Username)-                            (flagToList . fmap unUsername))--      ,option ['p'] ["password"]-        "Hackage password."-        reportPassword (\v flags -> flags { reportPassword = v })-        (reqArg' "PASSWORD" (toFlag . Password)-                            (flagToList . fmap unPassword))-      ]-  }--instance Monoid ReportFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ReportFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Get flags--- --------------------------------------------------------------data GetFlags = GetFlags {-    getDestDir          :: Flag FilePath,-    getPristine         :: Flag Bool,-    getIndexState       :: Flag TotalIndexState,-    getActiveRepos      :: Flag ActiveRepos,-    getSourceRepository :: Flag (Maybe RepoKind),-    getVerbosity        :: Flag Verbosity-  } deriving Generic--defaultGetFlags :: GetFlags-defaultGetFlags = GetFlags {-    getDestDir          = mempty,-    getPristine         = mempty,-    getIndexState       = mempty,-    getActiveRepos      = mempty,-    getSourceRepository = mempty,-    getVerbosity        = toFlag normal-   }--getCommand :: CommandUI GetFlags-getCommand = CommandUI {-    commandName         = "get",-    commandSynopsis     = "Download/Extract a package's source code (repository).",-    commandDescription  = Just $ \_ -> wrapText $-          "Creates a local copy of a package's source code. By default it gets "-       ++ "the source\ntarball and unpacks it in a local subdirectory. "-       ++ "Alternatively, with -s it will\nget the code from the source "-       ++ "repository specified by the package.\n",-    commandNotes        = Just $ \pname ->-          "Examples:\n"-       ++ "  " ++ pname ++ " get hlint\n"-       ++ "    Download the latest stable version of hlint;\n"-       ++ "  " ++ pname ++ " get lens --source-repository=head\n"-       ++ "    Download the source repository (i.e. git clone from github).\n",-    commandUsage        = usagePackages "get",-    commandDefaultFlags = defaultGetFlags,-    commandOptions      = \_ -> [-        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })--       ,option "d" ["destdir"]-         "Where to place the package source, defaults to the current directory."-         getDestDir (\v flags -> flags { getDestDir = v })-         (reqArgFlag "PATH")--       ,option "s" ["source-repository"]-         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."-         getSourceRepository (\v flags -> flags { getSourceRepository = v })-        (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository")-                                              (fmap (toFlag . Just) parsec))-                                  (Flag Nothing)-                                  (map (fmap show) . flagToList))--      , option [] ["index-state"]-          ("Use source package index state as it existed at a previous time. " ++-           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++-           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++-           "This determines which package versions are available as well as " ++-           ".cabal file revision is selected (unless --pristine is used).")-          getIndexState (\v flags -> flags { getIndexState = v })-          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " ++-                                       "unix-timestamps (e.g. '@1474732068'), " ++-                                       "a ISO8601 UTC timestamp " ++-                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")-                                      (toFlag `fmap` parsec))-                          (flagToList . fmap prettyShow))--       , option [] ["pristine"]-           ("Unpack the original pristine tarball, rather than updating the "-           ++ ".cabal file with the latest revision from the package archive.")-           getPristine (\v flags -> flags { getPristine = v })-           trueArg-       ]-  }---- 'cabal unpack' is a deprecated alias for 'cabal get'.-unpackCommand :: CommandUI GetFlags-unpackCommand = getCommand {-  commandName  = "unpack",-  commandUsage = usagePackages "unpack"-  }--instance Monoid GetFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup GetFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * List flags--- --------------------------------------------------------------data ListFlags = ListFlags-    { listInstalled       :: Flag Bool-    , listSimpleOutput    :: Flag Bool-    , listCaseInsensitive :: Flag Bool-    , listVerbosity       :: Flag Verbosity-    , listPackageDBs      :: [Maybe PackageDB]-    , listHcPath          :: Flag FilePath-    }-  deriving Generic--defaultListFlags :: ListFlags-defaultListFlags = ListFlags-    { listInstalled       = Flag False-    , listSimpleOutput    = Flag False-    , listCaseInsensitive = Flag True-    , listVerbosity       = toFlag normal-    , listPackageDBs      = []-    , listHcPath          = mempty-    }--listCommand  :: CommandUI ListFlags-listCommand = CommandUI {-    commandName         = "list",-    commandSynopsis     = "List packages matching a search string.",-    commandDescription  = Just $ \_ -> wrapText $-         "List all packages, or all packages matching one of the search"-      ++ " strings.\n"-      ++ "\n"-      ++ "Use the package database specified with --package-db. "-      ++ "If not specified, use the user package database.\n",-    commandNotes        = Just $ \pname ->-         "Examples:\n"-      ++ "  " ++ pname ++ " list pandoc\n"-      ++ "    Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n",-    commandUsage        = usageAlternatives "list" [ "[FLAGS]"-                                                   , "[FLAGS] STRINGS"],-    commandDefaultFlags = defaultListFlags,-    commandOptions      = const listOptions-  }--listOptions :: [OptionField ListFlags]-listOptions =-    [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })--    , option [] ["installed"]-        "Only print installed packages"-        listInstalled (\v flags -> flags { listInstalled = v })-        trueArg--    , option [] ["simple-output"]-        "Print in a easy-to-parse format"-        listSimpleOutput (\v flags -> flags { listSimpleOutput = v })-        trueArg-    , option ['i'] ["ignore-case"]-        "Ignore case destictions"-        listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v })-        (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"]))--    , option "" ["package-db"]-      (   "Append the given package database to the list of package"-       ++ " databases used (to satisfy dependencies and register into)."-       ++ " May be a specific file, 'global' or 'user'. The initial list"-       ++ " is ['global'], ['global', 'user'],"-       ++ " depending on context. Use 'clear' to reset the list to empty."-       ++ " See the user guide for details.")-      listPackageDBs (\v flags -> flags { listPackageDBs = v })-      (reqArg' "DB" readPackageDbList showPackageDbList)--    , option "w" ["with-compiler"]-      "give the path to a particular compiler"-      listHcPath (\v flags -> flags { listHcPath = v })-      (reqArgFlag "PATH")-    ]--listNeedsCompiler :: ListFlags -> Bool-listNeedsCompiler f =-    flagElim False (const True) (listHcPath f)-    || fromFlagOrDefault False (listInstalled f)--instance Monoid ListFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ListFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Info flags--- --------------------------------------------------------------data InfoFlags = InfoFlags {-    infoVerbosity  :: Flag Verbosity,-    infoPackageDBs :: [Maybe PackageDB]-  } deriving Generic--defaultInfoFlags :: InfoFlags-defaultInfoFlags = InfoFlags {-    infoVerbosity  = toFlag normal,-    infoPackageDBs = []-  }--infoCommand  :: CommandUI InfoFlags-infoCommand = CommandUI {-    commandName         = "info",-    commandSynopsis     = "Display detailed information about a particular package.",-    commandDescription  = Just $ \_ -> wrapText $-      "Use the package database specified with --package-db. "-      ++ "If not specified, use the user package database.\n",-    commandNotes        = Nothing,-    commandUsage        = usageAlternatives "info" ["[FLAGS] PACKAGES"],-    commandDefaultFlags = defaultInfoFlags,-    commandOptions      = \_ -> [-        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })--        , option "" ["package-db"]-          (   "Append the given package database to the list of package"-           ++ " databases used (to satisfy dependencies and register into)."-           ++ " May be a specific file, 'global' or 'user'. The initial list"-           ++ " is ['global'], ['global', 'user'],"-           ++ " depending on context. Use 'clear' to reset the list to empty."-           ++ " See the user guide for details.")-          infoPackageDBs (\v flags -> flags { infoPackageDBs = v })-          (reqArg' "DB" readPackageDbList showPackageDbList)--        ]-  }--instance Monoid InfoFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup InfoFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Install flags--- ---------------------------------------------------------------- | Install takes the same flags as configure along with a few extras.----data InstallFlags = InstallFlags {-    installDocumentation    :: Flag Bool,-    installHaddockIndex     :: Flag PathTemplate,-    installDest             :: Flag Cabal.CopyDest,-    installDryRun           :: Flag Bool,-    installMaxBackjumps     :: Flag Int,-    installReorderGoals     :: Flag ReorderGoals,-    installCountConflicts   :: Flag CountConflicts,-    installFineGrainedConflicts :: Flag FineGrainedConflicts,-    installMinimizeConflictSet :: Flag MinimizeConflictSet,-    installIndependentGoals :: Flag IndependentGoals,-    installShadowPkgs       :: Flag ShadowPkgs,-    installStrongFlags      :: Flag StrongFlags,-    installAllowBootLibInstalls :: Flag AllowBootLibInstalls,-    installOnlyConstrained  :: Flag OnlyConstrained,-    installReinstall        :: Flag Bool,-    installAvoidReinstalls  :: Flag AvoidReinstalls,-    installOverrideReinstall :: Flag Bool,-    installUpgradeDeps      :: Flag Bool,-    installOnly             :: Flag Bool,-    installOnlyDeps         :: Flag Bool,-    installIndexState       :: Flag TotalIndexState,-    installRootCmd          :: Flag String,-    installSummaryFile      :: NubList PathTemplate,-    installLogFile          :: Flag PathTemplate,-    installBuildReports     :: Flag ReportLevel,-    installReportPlanningFailure :: Flag Bool,-    -- Note: symlink-bindir is no longer used by v2-install and can be removed-    -- when removing v1 commands-    installSymlinkBinDir    :: Flag FilePath,-    installPerComponent     :: Flag Bool,-    installOneShot          :: Flag Bool,-    installNumJobs          :: Flag (Maybe Int),-    installKeepGoing        :: Flag Bool,-    installRunTests         :: Flag Bool,-    installOfflineMode      :: Flag Bool-  }-  deriving (Eq, Show, Generic)--instance Binary InstallFlags--defaultInstallFlags :: InstallFlags-defaultInstallFlags = InstallFlags {-    installDocumentation   = Flag False,-    installHaddockIndex    = Flag docIndexFile,-    installDest            = Flag Cabal.NoCopyDest,-    installDryRun          = Flag False,-    installMaxBackjumps    = Flag defaultMaxBackjumps,-    installReorderGoals    = Flag (ReorderGoals False),-    installCountConflicts  = Flag (CountConflicts True),-    installFineGrainedConflicts = Flag (FineGrainedConflicts True),-    installMinimizeConflictSet = Flag (MinimizeConflictSet False),-    installIndependentGoals= Flag (IndependentGoals False),-    installShadowPkgs      = Flag (ShadowPkgs False),-    installStrongFlags     = Flag (StrongFlags False),-    installAllowBootLibInstalls = Flag (AllowBootLibInstalls False),-    installOnlyConstrained = Flag OnlyConstrainedNone,-    installReinstall       = Flag False,-    installAvoidReinstalls = Flag (AvoidReinstalls False),-    installOverrideReinstall = Flag False,-    installUpgradeDeps     = Flag False,-    installOnly            = Flag False,-    installOnlyDeps        = Flag False,-    installIndexState      = mempty,-    installRootCmd         = mempty,-    installSummaryFile     = mempty,-    installLogFile         = mempty,-    installBuildReports    = Flag NoReports,-    installReportPlanningFailure = Flag False,-    installSymlinkBinDir   = mempty,-    installPerComponent    = Flag True,-    installOneShot         = Flag False,-    installNumJobs         = mempty,-    installKeepGoing       = Flag False,-    installRunTests        = mempty,-    installOfflineMode     = Flag False-  }-  where-    docIndexFile = toPathTemplate ("$datadir" </> "doc"-                                   </> "$arch-$os-$compiler" </> "index.html")--defaultMaxBackjumps :: Int-defaultMaxBackjumps = 4000--defaultSolver :: PreSolver-defaultSolver = AlwaysModular--allSolvers :: String-allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver]))--installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags-                            , HaddockFlags, TestFlags, BenchmarkFlags-                            )-installCommand = CommandUI {-  commandName         = "install",-  commandSynopsis     = "Install packages.",-  commandUsage        = usageAlternatives "v1-install" [ "[FLAGS]"-                                                    , "[FLAGS] PACKAGES"-                                                    ],-  commandDescription  = Just $ \_ -> wrapText $-        "Installs one or more packages. By default, the installed package"-     ++ " will be registered in the user's package database."-     ++ "\n"-     ++ "If PACKAGES are specified, downloads and installs those packages."-     ++ " Otherwise, install the package in the current directory (and/or its"-     ++ " dependencies) (there must be exactly one .cabal file in the current"-     ++ " directory).\n"-     ++ "\n"-     ++ "The flags to `v1-install` are saved and"-     ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for"-     ++ " `v1-configure` for a list of commands being affected.\n"-     ++ "\n"-     ++ "Installed executables will by default"-     ++ " be put into `~/.cabal/bin/`."-     ++ " If you want installed executable to be available globally, make"-     ++ " sure that the PATH environment variable contains that directory.\n"-     ++ "\n",-  commandNotes        = Just $ \pname ->-        ( case commandNotes-               $ Cabal.configureCommand defaultProgramDb-          of Just desc -> desc pname ++ "\n"-             Nothing   -> ""-        )-     ++ "Examples:\n"-     ++ "  " ++ pname ++ " v1-install                 "-     ++ "    Package in the current directory\n"-     ++ "  " ++ pname ++ " v1-install foo             "-     ++ "    Package from the hackage server\n"-     ++ "  " ++ pname ++ " v1-install foo-1.0         "-     ++ "    Specific version of a package\n"-     ++ "  " ++ pname ++ " v1-install 'foo < 2'       "-     ++ "    Constrained package version\n"-     ++ "  " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"-     ++ "  " ++ (map (const ' ') pname)-                      ++ "                         "-     ++ "    Change installation destination\n",-  commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty),-  commandOptions      = \showOrParseArgs ->-       liftOptions get1 set1-       -- Note: [Hidden Flags]-       -- hide "constraint", "dependency", and-       -- "exact-configuration" from the configure options.-       (filter ((`notElem` ["constraint", "dependency"-                           , "exact-configuration"])-                . optionName) $-                              configureOptions   showOrParseArgs)-    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)-    ++ liftOptions get3 set3-       -- hide "target-package-db" flag from the-       -- install options.-       (filter ((`notElem` ["target-package-db"])-                . optionName) $-                              installOptions     showOrParseArgs)-    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)-    ++ liftOptions get5 set5 (testOptions        showOrParseArgs)-    ++ liftOptions get6 set6 (benchmarkOptions   showOrParseArgs)-  }-  where-    get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)-    get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f)-    get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f)-    get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f)-    get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f)-    get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f)--haddockCommand :: CommandUI HaddockFlags-haddockCommand = Cabal.haddockCommand-  { commandUsage = usageAlternatives "v1-haddock" $-      [ "[FLAGS]", "COMPONENTS [FLAGS]" ]-  }--filterHaddockArgs :: [String] -> Version -> [String]-filterHaddockArgs args cabalLibVersion-  | cabalLibVersion >= mkVersion [2,3,0] = args_latest-  | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0-  | otherwise = args_latest-  where-    args_latest = args--    -- Cabal < 2.3 doesn't know about per-component haddock-    args_2_3_0 = []--filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags-filterHaddockFlags flags cabalLibVersion-  | cabalLibVersion >= mkVersion [2,3,0] = flags_latest-  | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0-  | otherwise = flags_latest-  where-    flags_latest = flags--    flags_2_3_0 = flags_latest {-      -- Cabal < 2.3 doesn't know about per-component haddock-      haddockArgs = []-      }--haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]-haddockOptions showOrParseArgs-  = [ opt { optionName = "haddock-" ++ name,-            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr-                          | descr <- optionDescr opt] }-    | opt <- commandOptions Cabal.haddockCommand showOrParseArgs-    , let name = optionName opt-    , name `elem` ["hoogle", "html", "html-location"-                  ,"executables", "tests", "benchmarks", "all", "internal", "css"-                  ,"hyperlink-source", "quickjump", "hscolour-css"-                  ,"contents-location", "for-hackage"]-    ]--testOptions :: ShowOrParseArgs -> [OptionField TestFlags]-testOptions showOrParseArgs-  = [ opt { optionName = prefixTest name,-            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr-                          | descr <- optionDescr opt] }-    | opt <- commandOptions Cabal.testCommand showOrParseArgs-    , let name = optionName opt-    , name `elem` ["log", "machine-log", "show-details", "keep-tix-files"-                  ,"fail-when-no-test-suites", "test-options", "test-option"-                  ,"test-wrapper"]-    ]-  where-    prefixTest name | "test-" `isPrefixOf` name = name-                    | otherwise = "test-" ++ name--benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags]-benchmarkOptions showOrParseArgs-  = [ opt { optionName = prefixBenchmark name,-            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr-                          | descr <- optionDescr opt] }-    | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs-    , let name = optionName opt-    , name `elem` ["benchmark-options", "benchmark-option"]-    ]-  where-    prefixBenchmark name | "benchmark-" `isPrefixOf` name = name-                         | otherwise = "benchmark-" ++ name--fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a-fmapOptFlags modify (ReqArg d f p r w)    = ReqArg d (modify f) p r w-fmapOptFlags modify (OptArg d f p r i w)  = OptArg d (modify f) p r i w-fmapOptFlags modify (ChoiceOpt xs)        = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]-fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w--installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]-installOptions showOrParseArgs =-      [ option "" ["documentation"]-          "building of documentation"-          installDocumentation (\v flags -> flags { installDocumentation = v })-          (boolOpt [] [])--      , option [] ["doc-index-file"]-          "A central index of haddock API documentation (template cannot use $pkgid)"-          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })-          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)-                              (flagToList . fmap fromPathTemplate))--      , option [] ["dry-run"]-          "Do not install anything, only print what would be installed."-          installDryRun (\v flags -> flags { installDryRun = v })-          trueArg--      , option "" ["target-package-db"]-         "package database to install into. Required when using ${pkgroot} prefix."-         installDest (\v flags -> flags { installDest = v })-         (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb))-                            (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> []))-      ] ++--      optionSolverFlags showOrParseArgs-                        installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })-                        installReorderGoals     (\v flags -> flags { installReorderGoals     = v })-                        installCountConflicts   (\v flags -> flags { installCountConflicts   = v })-                        installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v })-                        installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v })-                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })-                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })-                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v })-                        installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v })-                        installOnlyConstrained  (\v flags -> flags { installOnlyConstrained  = v }) ++--      [ option [] ["reinstall"]-          "Install even if it means installing the same version again."-          installReinstall (\v flags -> flags { installReinstall = v })-          (yesNoOpt showOrParseArgs)--      , option [] ["avoid-reinstalls"]-          "Do not select versions that would destructively overwrite installed packages."-          (fmap asBool . installAvoidReinstalls)-          (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v })-          (yesNoOpt showOrParseArgs)--      , option [] ["force-reinstalls"]-          "Reinstall packages even if they will most likely break other installed packages."-          installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })-          (yesNoOpt showOrParseArgs)--      , option [] ["upgrade-dependencies"]-          "Pick the latest version for all dependencies, rather than trying to pick an installed version."-          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })-          (yesNoOpt showOrParseArgs)--      , option [] ["only-dependencies"]-          "Install only the dependencies necessary to build the given packages"-          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })-          (yesNoOpt showOrParseArgs)--      , option [] ["dependencies-only"]-          "A synonym for --only-dependencies"-          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })-          (yesNoOpt showOrParseArgs)--      , option [] ["index-state"]-          ("Use source package index state as it existed at a previous time. " ++-           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++-           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")-          installIndexState (\v flags -> flags { installIndexState = v })-          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " ++-                                       "unix-timestamps (e.g. '@1474732068'), " ++-                                       "a ISO8601 UTC timestamp " ++-                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")-                                      (toFlag `fmap` parsec))-                          (flagToList . fmap prettyShow))--      , option [] ["root-cmd"]-          "(No longer supported, do not use.)"-          installRootCmd (\v flags -> flags { installRootCmd = v })-          (reqArg' "COMMAND" toFlag flagToList)--      , option [] ["symlink-bindir"]-          "Add symlinks to installed executables into this directory."-           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })-           (reqArgFlag "DIR")--      , option [] ["build-summary"]-          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"-          installSummaryFile (\v flags -> flags { installSummaryFile = v })-          (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList))--      , option [] ["build-log"]-          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"-          installLogFile (\v flags -> flags { installLogFile = v })-          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)-                              (flagToList . fmap fromPathTemplate))--      , option [] ["remote-build-reporting"]-          "Generate build reports to send to a remote server (none, anonymous or detailed)."-          installBuildReports (\v flags -> flags { installBuildReports = v })-          (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', "-                                            ++ "'anonymous' or 'detailed'")-                                      (toFlag `fmap` parsec))-                          (flagToList . fmap prettyShow))--      , option [] ["report-planning-failure"]-          "Generate build reports when the dependency solver fails. This is used by the Hackage build bot."-          installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v })-          trueArg--      , option "" ["per-component"]-          "Per-component builds when possible"-          installPerComponent (\v flags -> flags { installPerComponent = v })-          (boolOpt [] [])--      , option [] ["one-shot"]-          "Do not record the packages in the world file."-          installOneShot (\v flags -> flags { installOneShot = v })-          (yesNoOpt showOrParseArgs)--      , option [] ["run-tests"]-          "Run package test suites during installation."-          installRunTests (\v flags -> flags { installRunTests = v })-          trueArg--      , optionNumJobs-        installNumJobs (\v flags -> flags { installNumJobs = v })--      , option [] ["keep-going"]-          "After a build failure, continue to build other unaffected packages."-          installKeepGoing (\v flags -> flags { installKeepGoing = v })-          trueArg--      , option [] ["offline"]-          "Don't download packages from the Internet."-          installOfflineMode (\v flags -> flags { installOfflineMode = v })-          (yesNoOpt showOrParseArgs)--      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"-                                        -- avoids-          ParseArgs ->-            [ option [] ["only"]-              "Only installs the package in the current directory."-              installOnly (\v flags -> flags { installOnly = v })-              trueArg ]-          _ -> []---instance Monoid InstallFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup InstallFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Upload flags--- ---------------------------------------------------------------- | Is this a candidate package or a package to be published?-data IsCandidate = IsCandidate | IsPublished-                 deriving Eq--data UploadFlags = UploadFlags {-    uploadCandidate   :: Flag IsCandidate,-    uploadDoc         :: Flag Bool,-    uploadUsername    :: Flag Username,-    uploadPassword    :: Flag Password,-    uploadPasswordCmd :: Flag [String],-    uploadVerbosity   :: Flag Verbosity-  } deriving Generic--defaultUploadFlags :: UploadFlags-defaultUploadFlags = UploadFlags {-    uploadCandidate   = toFlag IsCandidate,-    uploadDoc         = toFlag False,-    uploadUsername    = mempty,-    uploadPassword    = mempty,-    uploadPasswordCmd = mempty,-    uploadVerbosity   = toFlag normal-  }--uploadCommand :: CommandUI UploadFlags-uploadCommand = CommandUI {-    commandName         = "upload",-    commandSynopsis     = "Uploads source packages or documentation to Hackage.",-    commandDescription  = Nothing,-    commandNotes        = Just $ \_ ->-         "You can store your Hackage login in the ~/.cabal/config file\n"-      ++ relevantConfigValuesText ["username", "password", "password-command"],-    commandUsage        = \pname ->-         "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",-    commandDefaultFlags = defaultUploadFlags,-    commandOptions      = \_ ->-      [optionVerbosity uploadVerbosity-       (\v flags -> flags { uploadVerbosity = v })--      ,option [] ["publish"]-        "Publish the package instead of uploading it as a candidate."-        uploadCandidate (\v flags -> flags { uploadCandidate = v })-        (noArg (Flag IsPublished))--      ,option ['d'] ["documentation"]-        ("Upload documentation instead of a source package. "-        ++ "By default, this uploads documentation for a package candidate. "-        ++ "To upload documentation for "-        ++ "a published package, combine with --publish.")-        uploadDoc (\v flags -> flags { uploadDoc = v })-        trueArg--      ,option ['u'] ["username"]-        "Hackage username."-        uploadUsername (\v flags -> flags { uploadUsername = v })-        (reqArg' "USERNAME" (toFlag . Username)-                            (flagToList . fmap unUsername))--      ,option ['p'] ["password"]-        "Hackage password."-        uploadPassword (\v flags -> flags { uploadPassword = v })-        (reqArg' "PASSWORD" (toFlag . Password)-                            (flagToList . fmap unPassword))--      ,option ['P'] ["password-command"]-        "Command to get Hackage password."-        uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v })-        (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe))-      ]-  }--instance Monoid UploadFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup UploadFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Init flags--- --------------------------------------------------------------initCommand :: CommandUI IT.InitFlags-initCommand = CommandUI {-    commandName = "init",-    commandSynopsis = "Create a new .cabal package file.",-    commandDescription = Just $ \_ -> wrapText $-         "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n"-      ++ "\n"-      ++ "Calling init with no arguments creates an executable, "-      ++ "guessing as many options as possible. The interactive "-      ++ "mode can be invoked by the -i/--interactive flag, which "-      ++ "will try to guess as much as possible and prompt you for "-      ++ "the rest. You can change init to always be interactive by "-      ++ "setting the interactive flag in your configuration file. "-      ++ "Command-line arguments are provided for scripting purposes.\n",-    commandNotes = Nothing,-    commandUsage = \pname ->-         "Usage: " ++ pname ++ " init [FLAGS]\n",-    commandDefaultFlags = IT.defaultInitFlags,-    commandOptions = initOptions-  }--initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags]-initOptions _ =-  [ option ['i'] ["interactive"]-    "interactive mode."-    IT.interactive (\v flags -> flags { IT.interactive = v })-    (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"]))--  , option ['q'] ["quiet"]-    "Do not generate log messages to stdout."-    IT.quiet (\v flags -> flags { IT.quiet = v })-    trueArg--  , option [] ["no-comments"]-    "Do not generate explanatory comments in the .cabal file."-    IT.noComments (\v flags -> flags { IT.noComments = v })-    trueArg--  , option ['m'] ["minimal"]-    "Generate a minimal .cabal file, that is, do not include extra empty fields.  Also implies --no-comments."-    IT.minimal (\v flags -> flags { IT.minimal = v })-    trueArg--  , option [] ["overwrite"]-    "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."-    IT.overwrite (\v flags -> flags { IT.overwrite = v })-    trueArg--  , option [] ["package-dir", "packagedir"]-    "Root directory of the package (default = current directory)."-    IT.packageDir (\v flags -> flags { IT.packageDir = v })-    (reqArgFlag "DIRECTORY")--  , option ['p'] ["package-name"]-    "Name of the Cabal package to create."-    IT.packageName (\v flags -> flags { IT.packageName = v })-    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++)-                                  (toFlag `fmap` parsec))-                      (flagToList . fmap prettyShow))--  , option [] ["version"]-    "Initial version of the package."-    IT.version (\v flags -> flags { IT.version = v })-    (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++)-                                  (toFlag `fmap` parsec))-                      (flagToList . fmap prettyShow))--  , option [] ["cabal-version"]-    "Version of the Cabal specification."-    IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })-    (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++)-                                        (fmap (toFlag . getSpecVersion) parsec))-                            (flagToList . fmap (prettyShow . SpecVersion)))--  , option ['l'] ["license"]-    "Project license."-    IT.license (\v flags -> flags { IT.license = v })-    (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++)-                                  (toFlag `fmap` parsec))-                      (flagToList . fmap prettyShow))--  , option ['a'] ["author"]-    "Name of the project's author."-    IT.author (\v flags -> flags { IT.author = v })-    (reqArgFlag "NAME")--  , option ['e'] ["email"]-    "Email address of the maintainer."-    IT.email (\v flags -> flags { IT.email = v })-    (reqArgFlag "EMAIL")--  , option ['u'] ["homepage"]-    "Project homepage and/or repository."-    IT.homepage (\v flags -> flags { IT.homepage = v })-    (reqArgFlag "URL")--  , option ['s'] ["synopsis"]-    "Short project synopsis."-    IT.synopsis (\v flags -> flags { IT.synopsis = v })-    (reqArgFlag "TEXT")--  , option ['c'] ["category"]-    "Project category."-    IT.category (\v flags -> flags { IT.category = v })-    (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))-                        (flagToList . fmap (either id show)))--  , option ['x'] ["extra-source-file"]-    "Extra source file to be distributed with tarball."-    IT.extraSrc (\v flags -> flags { IT.extraSrc = v })-    (reqArg' "FILE" (Just . (:[]))-                    (fromMaybe []))--  , option [] ["lib", "is-library"]-    "Build a library."-    IT.packageType (\v flags -> flags { IT.packageType = v })-    (noArg (Flag IT.Library))--  , option [] ["exe", "is-executable"]-    "Build an executable."-    IT.packageType-    (\v flags -> flags { IT.packageType = v })-    (noArg (Flag IT.Executable))--    , option [] ["libandexe", "is-libandexe"]-    "Build a library and an executable."-    IT.packageType-    (\v flags -> flags { IT.packageType = v })-    (noArg (Flag IT.LibraryAndExecutable))--      , option [] ["tests"]-        "Generate a test suite for the library."-        IT.initializeTestSuite-        (\v flags -> flags { IT.initializeTestSuite = v })-        trueArg--      , option [] ["test-dir"]-        "Directory containing tests."-        IT.testDirs (\v flags -> flags { IT.testDirs = v })-        (reqArg' "DIR" (Just . (:[]))-                       (fromMaybe []))--  , option [] ["simple"]-    "Create a simple project with sensible defaults."-    IT.simpleProject-    (\v flags -> flags { IT.simpleProject = v })-    trueArg--  , 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-    (\v flags -> flags { IT.language = v })-    (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++)-                                   (toFlag `fmap` parsec))-                      (flagToList . fmap prettyShow))--  , option ['o'] ["expose-module"]-    "Export a module from the package."-    IT.exposedModules-    (\v flags -> flags { IT.exposedModules = v })-    (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++)-                                 ((Just . (:[])) `fmap` parsec))-                     (maybe [] (fmap prettyShow)))--  , option [] ["extension"]-    "Use a LANGUAGE extension (in the other-extensions field)."-    IT.otherExts-    (\v flags -> flags { IT.otherExts = v })-    (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++)-                                    ((Just . (:[])) `fmap` parsec))-                        (maybe [] (fmap prettyShow)))--  , option ['d'] ["dependency"]-    "Package dependency."-    IT.dependencies (\v flags -> flags { IT.dependencies = v })-    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++)-                                  ((Just . (:[])) `fmap` parsec))-                      (maybe [] (fmap prettyShow)))--  , option [] ["application-dir"]-    "Directory containing package application executable."-    IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v})-    (reqArg' "DIR" (Just . (:[]))-                   (fromMaybe []))--  , option [] ["source-dir", "sourcedir"]-    "Directory containing package library source."-    IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })-    (reqArg' "DIR" (Just . (:[]))-                   (fromMaybe []))--  , option [] ["build-tool"]-    "Required external build tool."-    IT.buildTools (\v flags -> flags { IT.buildTools = v })-    (reqArg' "TOOL" (Just . (:[]))-                    (fromMaybe []))--    -- NB: this is a bit of a transitional hack and will likely be-    -- removed again if `cabal init` is migrated to the v2-* command-    -- framework-  , option "w" ["with-compiler"]-    "give the path to a particular compiler"-    IT.initHcPath (\v flags -> flags { IT.initHcPath = v })-    (reqArgFlag "PATH")--  , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })-  ]---- --------------------------------------------------------------- * SDist flags--- --------------------------------------------------------------doctestCommand :: CommandUI DoctestFlags-doctestCommand = Cabal.doctestCommand-  { commandUsage = \pname ->  "Usage: " ++ pname ++ " v1-doctest [FLAGS]\n" }--copyCommand :: CommandUI CopyFlags-copyCommand = Cabal.copyCommand- { commandNotes = Just $ \pname ->-    "Examples:\n"-     ++ "  " ++ pname ++ " v1-copy           "-     ++ "    All the components in the package\n"-     ++ "  " ++ pname ++ " v1-copy foo       "-     ++ "    A component (i.e. lib, exe, test suite)"-  , commandUsage = usageAlternatives "v1-copy" $-    [ "[FLAGS]"-    , "COMPONENTS [FLAGS]"-    ]- }--registerCommand :: CommandUI RegisterFlags-registerCommand = Cabal.registerCommand- { commandUsage = \pname ->  "Usage: " ++ pname ++ " v1-register [FLAGS]\n" }---- --------------------------------------------------------------- * ActAsSetup flags--- --------------------------------------------------------------data ActAsSetupFlags = ActAsSetupFlags {-    actAsSetupBuildType :: Flag BuildType-} deriving Generic--defaultActAsSetupFlags :: ActAsSetupFlags-defaultActAsSetupFlags = ActAsSetupFlags {-    actAsSetupBuildType = toFlag Simple-}--actAsSetupCommand :: CommandUI ActAsSetupFlags-actAsSetupCommand = CommandUI {-  commandName         = "act-as-setup",-  commandSynopsis     = "Run as-if this was a Setup.hs",-  commandDescription  = Nothing,-  commandNotes        = Nothing,-  commandUsage        = \pname ->-    "Usage: " ++ pname ++ " act-as-setup\n",-  commandDefaultFlags = defaultActAsSetupFlags,-  commandOptions      = \_ ->-      [option "" ["build-type"]-         "Use the given build type."-         actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })-         (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++)-                               (fmap toFlag parsec))-                              (map prettyShow . flagToList))-      ]-}--instance Monoid ActAsSetupFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ActAsSetupFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * Exec Flags--- --------------------------------------------------------------data ExecFlags = ExecFlags {-  execVerbosity :: Flag Verbosity,-  execDistPref  :: Flag FilePath-} deriving Generic--defaultExecFlags :: ExecFlags-defaultExecFlags = ExecFlags {-  execVerbosity = toFlag normal,-  execDistPref  = NoFlag-  }--execCommand :: CommandUI ExecFlags-execCommand = CommandUI {-  commandName         = "exec",-  commandSynopsis     = "Give a command access to the sandbox package repository.",-  commandDescription  = Just $ \pname -> wrapText $-       -- TODO: this is too GHC-focused for my liking..-       "A directly invoked GHC will not automatically be aware of any"-    ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what"-    ++ " GHC uses. `" ++ pname ++ " v1-exec` can be used to modify this variable:"-    ++ " COMMAND will be executed in a modified environment and thereby uses"-    ++ " the sandbox package database.\n"-    ++ "\n"-    ++ "If there is no sandbox, behaves as identity (executing COMMAND).\n"-    ++ "\n"-    ++ "Note that other " ++ pname ++ " commands change the environment"-    ++ " variable appropriately already, so there is no need to wrap those"-    ++ " in `" ++ pname ++ " v1-exec`. But with `" ++ pname ++ " v1-exec`, the user"-    ++ " has more control and can, for example, execute custom scripts which"-    ++ " indirectly execute GHC.\n"-    ++ "\n"-    ++ "Note that `" ++ pname ++ " v1-repl` is different from `" ++ pname-    ++ " v1-exec -- ghci` as the latter will not forward any additional flags"-    ++ " being defined in the local package to ghci.\n"-    ++ "\n"-    ++ "See `" ++ pname ++ " sandbox`.\n",-  commandNotes        = Just $ \pname ->-       "Examples:\n"-    ++ "  " ++ pname ++ " v1-exec -- ghci -Wall\n"-    ++ "    Start a repl session with sandbox packages and all warnings;\n"-    ++ "  " ++ pname ++ " v1-exec gitit -- -f gitit.cnf\n"-    ++ "    Give gitit access to the sandbox packages, and pass it a flag;\n"-    ++ "  " ++ pname ++ " v1-exec runghc Foo.hs\n"-    ++ "    Execute runghc on Foo.hs with runghc configured to use the\n"-    ++ "    sandbox package database (if a sandbox is being used).\n",-  commandUsage        = \pname ->-       "Usage: " ++ pname ++ " v1-exec [FLAGS] [--] COMMAND [--] [ARGS]\n",--  commandDefaultFlags = defaultExecFlags,-  commandOptions      = \showOrParseArgs ->-    [ optionVerbosity execVerbosity-      (\v flags -> flags { execVerbosity = v })-    , Cabal.optionDistPref-       execDistPref (\d flags -> flags { execDistPref = d })-       showOrParseArgs-    ]-  }--instance Monoid ExecFlags where-  mempty = gmempty-  mappend = (<>)--instance Semigroup ExecFlags where-  (<>) = gmappend---- --------------------------------------------------------------- * UserConfig flags--- --------------------------------------------------------------data UserConfigFlags = UserConfigFlags {-  userConfigVerbosity   :: Flag Verbosity,-  userConfigForce       :: Flag Bool,-  userConfigAppendLines :: Flag [String]-  } deriving Generic--instance Monoid UserConfigFlags where-  mempty = UserConfigFlags {-    userConfigVerbosity   = toFlag normal,-    userConfigForce       = toFlag False,-    userConfigAppendLines = toFlag []-    }-  mappend = (<>)--instance Semigroup UserConfigFlags where-  (<>) = gmappend--userConfigCommand :: CommandUI UserConfigFlags-userConfigCommand = CommandUI {-  commandName         = "user-config",-  commandSynopsis     = "Display and update the user's global cabal configuration.",-  commandDescription  = Just $ \_ -> wrapText $-       "When upgrading cabal, the set of configuration keys and their default"-    ++ " values may change. This command provides means to merge the existing"-    ++ " config in ~/.cabal/config"-    ++ " (i.e. all bindings that are actually defined and not commented out)"-    ++ " and the default config of the new version.\n"-    ++ "\n"-    ++ "init: Creates a new config file at either ~/.cabal/config or as"-    ++ " specified by --config-file, if given. An existing file won't be "-    ++ " overwritten unless -f or --force is given.\n"-    ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and"-    ++ " the default configuration that would be created by cabal if the"-    ++ " config file did not exist.\n"-    ++ "update: Applies the pseudo-diff to the configuration that would be"-    ++ " created by default, and write the result back to ~/.cabal/config.",--  commandNotes        = Nothing,-  commandUsage        = usageAlternatives "user-config" ["init", "diff", "update"],-  commandDefaultFlags = mempty,-  commandOptions      = \ _ -> [-   optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })- , option ['f'] ["force"]-     "Overwrite the config file if it already exists."-     userConfigForce (\v flags -> flags { userConfigForce = v })-     trueArg- , option ['a'] ["augment"]-     "Additional setting to augment the config file (replacing a previous setting if it existed)."-     userConfigAppendLines (\v flags -> flags-                               {userConfigAppendLines =-                                   Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)})-     (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe))-   ]-  }----- --------------------------------------------------------------- * GetOpt Utils--- --------------------------------------------------------------reqArgFlag :: ArgPlaceHolder ->-              MkOptDescr (b -> Flag String) (Flag String -> b -> b) b-reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList--liftOptions :: (b -> a) -> (a -> b -> b)-            -> [OptionField a] -> [OptionField b]-liftOptions get set = map (liftOption get set)--yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b-yesNoOpt ShowArgs sf lf = trueArg sf lf-yesNoOpt _        sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf--optionSolver :: (flags -> Flag PreSolver)-             -> (Flag PreSolver -> flags -> flags)-             -> OptionField flags-optionSolver get set =-  option [] ["solver"]-    ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")-    get set-    (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers)-                                    (toFlag `fmap` parsec))-                     (flagToList . fmap prettyShow))--optionSolverFlags :: ShowOrParseArgs-                  -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)-                  -> (flags -> Flag ReorderGoals)     -> (Flag ReorderGoals     -> flags -> flags)-                  -> (flags -> Flag CountConflicts)   -> (Flag CountConflicts   -> flags -> flags)-                  -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags)-                  -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags)-                  -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)-                  -> (flags -> Flag ShadowPkgs)       -> (Flag ShadowPkgs       -> flags -> flags)-                  -> (flags -> Flag StrongFlags)      -> (Flag StrongFlags      -> flags -> flags)-                  -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags)-                  -> (flags -> Flag OnlyConstrained)  -> (Flag OnlyConstrained  -> flags -> flags)-                  -> [OptionField flags]-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc-                  getfgc setfgc getmc setmc getig setig getsip setsip-                  getstrfl setstrfl getib setib getoc setoc =-  [ option [] ["max-backjumps"]-      ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")-      getmbj setmbj-      (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral))-                    (map show . flagToList))-  , option [] ["reorder-goals"]-      "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."-      (fmap asBool . getrg)-      (setrg . fmap ReorderGoals)-      (yesNoOpt showOrParseArgs)-  , option [] ["count-conflicts"]-      "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)."-      (fmap asBool . getcc)-      (setcc . fmap CountConflicts)-      (yesNoOpt showOrParseArgs)-  , option [] ["fine-grained-conflicts"]-      "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)."-      (fmap asBool . getfgc)-      (setfgc . fmap FineGrainedConflicts)-      (yesNoOpt showOrParseArgs)-  , option [] ["minimize-conflict-set"]-      ("When there is no solution, try to improve the error message by finding "-        ++ "a minimal conflict set (default: false). May increase run time "-        ++ "significantly.")-      (fmap asBool . getmc)-      (setmc . fmap MinimizeConflictSet)-      (yesNoOpt showOrParseArgs)-  , option [] ["independent-goals"]-      "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."-      (fmap asBool . getig)-      (setig . fmap IndependentGoals)-      (yesNoOpt showOrParseArgs)-  , option [] ["shadow-installed-packages"]-      "If multiple package instances of the same version are installed, treat all but one as shadowed."-      (fmap asBool . getsip)-      (setsip . fmap ShadowPkgs)-      (yesNoOpt showOrParseArgs)-  , option [] ["strong-flags"]-      "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."-      (fmap asBool . getstrfl)-      (setstrfl . fmap StrongFlags)-      (yesNoOpt showOrParseArgs)-  , option [] ["allow-boot-library-installs"]-      "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell."-      (fmap asBool . getib)-      (setib . fmap AllowBootLibInstalls)-      (yesNoOpt showOrParseArgs)-  , option [] ["reject-unconstrained-dependencies"]-      "Require these packages to have constraints on them if they are to be selected (default: none)."-      getoc-      setoc-      (reqArg "none|all"-         (parsecToReadE-            (const "reject-unconstrained-dependencies must be 'none' or 'all'")-            (toFlag `fmap` parsec))-         (flagToList . fmap prettyShow))--  ]--usagePackages :: String -> String -> String-usagePackages name pname =-     "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"--usageFlags :: String -> String -> String-usageFlags name pname =-  "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"----TODO: do we want to allow per-package flags?-parsePackageArgs :: [String] -> Either String [PackageVersionConstraint]-parsePackageArgs = traverse p where-    p arg = case eitherParsec arg of-        Right pvc -> Right pvc-        Left err  -> Left $-          show arg ++ " is not valid syntax for a package name or"-                   ++ " package dependency. " ++ err --showRemoteRepo :: RemoteRepo -> String-showRemoteRepo = prettyShow--readRemoteRepo :: String -> Maybe RemoteRepo-readRemoteRepo = simpleParsec--showLocalRepo :: LocalRepo -> String-showLocalRepo = prettyShow--readLocalRepo :: String -> Maybe LocalRepo-readLocalRepo = simpleParsec---- --------------------------------------------------------------- * Helpers for Documentation--- --------------------------------------------------------------relevantConfigValuesText :: [String] -> String-relevantConfigValuesText vs =-     "Relevant global configuration keys:\n"-  ++ concat ["  " ++ v ++ "\n" |v <- vs]
− Distribution/Client/SetupWrapper.hs 
@@ -1,919 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.SetupWrapper--- Copyright   :  (c) The University of Glasgow 2006,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  alpha--- Portability :  portable------ An interface to building and installing Cabal packages.--- If the @Built-Type@ field is specified as something other than--- 'Custom', and the current version of Cabal is acceptable, this performs--- setup actions directly.  Otherwise it builds the setup script and--- runs it with the given arguments.--module Distribution.Client.SetupWrapper (-    getSetup, runSetup, runSetupCommand, setupWrapper,-    SetupScriptOptions(..),-    defaultSetupScriptOptions,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)-import qualified Distribution.Make as Make-import qualified Distribution.Simple as Simple-import Distribution.Version-         ( Version, mkVersion, versionNumbers, VersionRange, anyVersion-         , intersectVersionRanges, orLaterVersion-         , withinRange )-import qualified Distribution.Backpack as Backpack-import Distribution.Package-         ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId-         , PackageId, mkPackageName-         , PackageIdentifier(..), packageVersion, packageName )-import Distribution.PackageDescription-         ( GenericPackageDescription(packageDescription)-         , PackageDescription(..), specVersion, buildType-         , BuildType(..) )-import Distribution.Types.ModuleRenaming (defaultRenaming)-import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription )-import Distribution.Simple.Configure-         ( configCompilerEx )-import Distribution.Compiler-         ( buildCompilerId, CompilerFlavor(GHC, GHCJS) )-import Distribution.Simple.Compiler-         ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack )-import Distribution.Simple.PreProcess-         ( runSimplePreProcessor, ppUnlit )-import Distribution.Simple.Build.Macros-         ( generatePackageVersionMacros )-import Distribution.Simple.Program-         ( ProgramDb, emptyProgramDb-         , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram-         , ghcjsProgram )-import Distribution.Simple.Program.Find-         ( programSearchPathAsPATHVar-         , ProgramSearchPathEntry(ProgramSearchPathDir) )-import Distribution.Simple.Program.Run-         ( getEffectiveEnvironment )-import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.BuildPaths-         ( defaultDistPref, exeExtension )--import Distribution.Simple.Command-         ( CommandUI(..), commandShowOptions )-import Distribution.Simple.Program.GHC-         ( GhcMode(..), GhcOptions(..), renderGhcOptions )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Client.Types-import Distribution.Client.Config-         ( getCabalDir )-import Distribution.Client.IndexUtils-         ( getInstalledPackages )-import Distribution.Client.JobControl-         ( Lock, criticalSection )-import Distribution.Simple.Setup-         ( Flag(..) )-import Distribution.Utils.Generic-         ( safeHead )-import Distribution.Simple.Utils-         ( die', debug, info, infoNoWrap-         , cabalVersion, tryFindPackageDesc-         , createDirectoryIfMissingVerbose, installExecutableFile-         , copyFileVerbose, rewriteFileEx, rewriteFileLBS )-import Distribution.Client.Utils-         ( inDir, tryCanonicalizePath, withExtraPathEnv-         , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides-#ifdef mingw32_HOST_OS-         , canonicalizePathNoThrow-#endif-         )--import Distribution.ReadE-import Distribution.System ( Platform(..), buildPlatform )-import Distribution.Utils.NubList-         ( toNubListR )-import Distribution.Verbosity-import Distribution.Compat.Stack--import System.Directory    ( doesFileExist )-import System.FilePath     ( (</>), (<.>) )-import System.IO           ( Handle, hPutStr )-import Distribution.Compat.Process (createProcess)-import System.Process      ( StdStream(..), proc, waitForProcess-                           , ProcessHandle )-import qualified System.Process as Process-import Data.List           ( foldl1' )-import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath )--import qualified Data.ByteString.Lazy as BS--#ifdef mingw32_HOST_OS-import Distribution.Simple.Utils-         ( withTempDirectory )--import Control.Exception   ( bracket )-import System.FilePath     ( equalFilePath, takeDirectory )-import System.Directory    ( doesDirectoryExist )-import qualified System.Win32 as Win32-#endif---- | @Setup@ encapsulates the outcome of configuring a setup method to build a--- particular package.-data Setup = Setup { setupMethod        :: SetupMethod-                   , setupScriptOptions :: SetupScriptOptions-                   , setupVersion       :: Version-                   , setupBuildType     :: BuildType-                   , setupPackage       :: PackageDescription-                   }---- | @SetupMethod@ represents one of the methods used to run Cabal commands.-data SetupMethod = InternalMethod-                   -- ^ run Cabal commands through \"cabal\" in the-                   -- current process-                 | SelfExecMethod-                   -- ^ run Cabal commands through \"cabal\" as a-                   -- child process-                 | ExternalMethod FilePath-                   -- ^ run Cabal commands through a custom \"Setup\" executable---- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two--- parts: one that has no policy and just does as it's told with all the--- explicit options, and an optional initial part that applies certain--- policies (like if we should add the Cabal lib as a dep, and if so which--- version). This could be structured as an action that returns a fully--- elaborated 'SetupScriptOptions' containing no remaining policy choices.------ See also the discussion at https://github.com/haskell/cabal/pull/3094---- | @SetupScriptOptions@ are options used to configure and run 'Setup', as--- opposed to options given to the Cabal command at runtime.-data SetupScriptOptions = SetupScriptOptions {-    -- | The version of the Cabal library to use (if 'useDependenciesExclusive'-    -- is not set). A suitable version of the Cabal library must be installed-    -- (or for some build-types be the one cabal-install was built with).-    ---    -- The version found also determines the version of the Cabal specification-    -- that we us for talking to the Setup.hs, unless overridden by-    -- 'useCabalSpecVersion'.-    ---    useCabalVersion          :: VersionRange,--    -- | This is the version of the Cabal specification that we believe that-    -- this package uses. This affects the semantics and in particular the-    -- Setup command line interface.-    ---    -- This is similar to 'useCabalVersion' but instead of probing the system-    -- for a version of the /Cabal library/ you just say exactly which version-    -- of the /spec/ we will use. Using this also avoid adding the Cabal-    -- library as an additional dependency, so add it to 'useDependencies'-    -- if needed.-    ---    useCabalSpecVersion      :: Maybe Version,-    useCompiler              :: Maybe Compiler,-    usePlatform              :: Maybe Platform,-    usePackageDB             :: PackageDBStack,-    usePackageIndex          :: Maybe InstalledPackageIndex,-    useProgramDb             :: ProgramDb,-    useDistPref              :: FilePath,-    useLoggingHandle         :: Maybe Handle,-    useWorkingDir            :: Maybe FilePath,-    -- | Extra things to add to PATH when invoking the setup script.-    useExtraPathEnv          :: [FilePath],-    -- | Extra environment variables paired with overrides, where-    ---    -- * @'Just' v@ means \"set the environment variable's value to @v@\".-    -- * 'Nothing' means \"unset the environment variable\".-    useExtraEnvOverrides     :: [(String, Maybe FilePath)],-    forceExternalSetupMethod :: Bool,--    -- | List of dependencies to use when building Setup.hs.-    useDependencies :: [(ComponentId, PackageId)],--    -- | Is the list of setup dependencies exclusive?-    ---    -- When this is @False@, if we compile the Setup.hs script we do so with the-    -- list in 'useDependencies' but all other packages in the environment are-    -- also visible. A suitable version of @Cabal@ library (see-    -- 'useCabalVersion') is also added to the list of dependencies, unless-    -- 'useDependencies' already contains a Cabal dependency.-    ---    -- When @True@, only the 'useDependencies' packages are used, with other-    -- packages in the environment hidden.-    ---    -- This feature is here to support the setup stanza in .cabal files that-    -- specifies explicit (and exclusive) dependencies, as well as the old-    -- style with no dependencies.-    useDependenciesExclusive :: Bool,--    -- | Should we build the Setup.hs with CPP version macros available?-    -- We turn this on when we have a setup stanza in .cabal that declares-    -- explicit setup dependencies.-    ---    useVersionMacros         :: Bool,--    -- Used only by 'cabal clean' on Windows.-    ---    -- Note: win32 clean hack-    --------------------------    -- On Windows, running './dist/setup/setup clean' doesn't work because the-    -- setup script will try to delete itself (which causes it to fail horribly,-    -- unlike on Linux). So we have to move the setup exe out of the way first-    -- and then delete it manually. This applies only to the external setup-    -- method.-    useWin32CleanHack        :: Bool,--    -- Used only when calling setupWrapper from parallel code to serialise-    -- access to the setup cache; should be Nothing otherwise.-    ---    -- Note: setup exe cache-    -------------------------    -- When we are installing in parallel, we always use the external setup-    -- method. Since compiling the setup script each time adds noticeable-    -- overhead, we use a shared setup script cache-    -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal-    -- version) combination the cache holds a compiled setup script-    -- executable. This only affects the Simple build type; for the Custom,-    -- Configure and Make build types we always compile the setup script anew.-    setupCacheLock           :: Maybe Lock,--    -- | Is the task we are going to run an interactive foreground task,-    -- or an non-interactive background task? Based on this flag we-    -- decide whether or not to delegate ctrl+c to the spawned task-    isInteractive            :: Bool-  }--defaultSetupScriptOptions :: SetupScriptOptions-defaultSetupScriptOptions = SetupScriptOptions {-    useCabalVersion          = anyVersion,-    useCabalSpecVersion      = Nothing,-    useCompiler              = Nothing,-    usePlatform              = Nothing,-    usePackageDB             = [GlobalPackageDB, UserPackageDB],-    usePackageIndex          = Nothing,-    useDependencies          = [],-    useDependenciesExclusive = False,-    useVersionMacros         = False,-    useProgramDb             = emptyProgramDb,-    useDistPref              = defaultDistPref,-    useLoggingHandle         = Nothing,-    useWorkingDir            = Nothing,-    useExtraPathEnv          = [],-    useExtraEnvOverrides     = [],-    useWin32CleanHack        = False,-    forceExternalSetupMethod = False,-    setupCacheLock           = Nothing,-    isInteractive            = False-  }--workingDir :: SetupScriptOptions -> FilePath-workingDir options =-  case fromMaybe "" (useWorkingDir options) of-    []  -> "."-    dir -> dir---- | A @SetupRunner@ implements a 'SetupMethod'.-type SetupRunner = Verbosity-                 -> SetupScriptOptions-                 -> BuildType-                 -> [String]-                 -> IO ()---- | Prepare to build a package by configuring a 'SetupMethod'. The returned--- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed--- during the configuration process; the final values are given by--- 'setupScriptOptions'.-getSetup :: Verbosity-         -> SetupScriptOptions-         -> Maybe PackageDescription-         -> IO Setup-getSetup verbosity options mpkg = do-  pkg <- maybe getPkg return mpkg-  let options'    = options {-                      useCabalVersion = intersectVersionRanges-                                          (useCabalVersion options)-                                          (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))-                    }-      buildType'  = buildType pkg-  (version, method, options'') <--    getSetupMethod verbosity options' pkg buildType'-  return Setup { setupMethod = method-               , setupScriptOptions = options''-               , setupVersion = version-               , setupBuildType = buildType'-               , setupPackage = pkg-               }-  where-    getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options))-         >>= readGenericPackageDescription verbosity-         >>= return . packageDescription---- | Decide if we're going to be able to do a direct internal call to the--- entry point in the Cabal library or if we're going to have to compile--- and execute an external Setup.hs script.----getSetupMethod-  :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType-  -> IO (Version, SetupMethod, SetupScriptOptions)-getSetupMethod verbosity options pkg buildType'-  | buildType' == Custom-    || maybe False (cabalVersion /=) (useCabalSpecVersion options)-    || not (cabalVersion `withinRange` useCabalVersion options)    =-         getExternalSetupMethod verbosity options pkg buildType'-  | isJust (useLoggingHandle options)-    -- Forcing is done to use an external process e.g. due to parallel-    -- build concerns.-    || forceExternalSetupMethod options =-        return (cabalVersion, SelfExecMethod, options)-  | otherwise = return (cabalVersion, InternalMethod, options)--runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)-runSetupMethod InternalMethod = internalSetupMethod-runSetupMethod (ExternalMethod path) = externalSetupMethod path-runSetupMethod SelfExecMethod = selfExecSetupMethod---- | Run a configured 'Setup' with specific arguments.-runSetup :: Verbosity -> Setup-         -> [String]  -- ^ command-line arguments-         -> IO ()-runSetup verbosity setup args0 = do-  let method = setupMethod setup-      options = setupScriptOptions setup-      bt = setupBuildType setup-      args = verbosityHack (setupVersion setup) args0-  when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $-    infoNoWrap verbose $-        "Applied verbosity hack:\n" ++-        "  Before: " ++ show args0 ++ "\n" ++-        "  After:  " ++ show args ++ "\n"-  runSetupMethod method verbosity options bt args---- | This is a horrible hack to make sure passing fancy verbosity--- flags (e.g., @-v'info +callstack'@) doesn't break horribly on--- old Setup.  We can't do it in 'filterConfigureFlags' because--- verbosity applies to ALL commands.-verbosityHack :: Version -> [String] -> [String]-verbosityHack ver args0-    | ver >= mkVersion [2,1]  = args0-    | otherwise = go args0-  where-    go (('-':'v':rest) : args)-        | Just rest' <- munch rest = ("-v" ++ rest') : go args-    go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args)-        | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args-    go ("--verbose" : rest : args)-        | Just rest' <- munch rest = "--verbose" : rest' : go args-    go rest@("--" : _) = rest-    go (arg:args) = arg : go args-    go [] = []--    munch rest =-        case runReadE flagToVerbosity rest of-            Right v-              | ver < mkVersion [2,0], verboseHasFlags v-              -- We could preserve the prefix, but since we're assuming-              -- it's Cabal's verbosity flag, we can assume that-              -- any format is OK-              -> Just (showForCabal (verboseNoFlags v))-              | ver < mkVersion [2,1], isVerboseTimestamp v-              -- +timestamp wasn't yet available in Cabal-2.0.0-              -> Just (showForCabal (verboseNoTimestamp v))-            _ -> Nothing---- | Run a command through a configured 'Setup'.-runSetupCommand :: Verbosity -> Setup-                -> CommandUI flags  -- ^ command definition-                -> flags  -- ^ command flags-                -> [String] -- ^ extra command-line arguments-                -> IO ()-runSetupCommand verbosity setup cmd flags extraArgs = do-  let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs-  runSetup verbosity setup args---- | Configure a 'Setup' and run a command in one step. The command flags--- may depend on the Cabal library version in use.-setupWrapper :: Verbosity-             -> SetupScriptOptions-             -> Maybe PackageDescription-             -> CommandUI flags-             -> (Version -> flags)-                -- ^ produce command flags given the Cabal library version-             -> (Version -> [String])-             -> IO ()-setupWrapper verbosity options mpkg cmd flags extraArgs = do-  setup <- getSetup verbosity options mpkg-  runSetupCommand verbosity setup-                  cmd (flags $ setupVersion setup)-                      (extraArgs $ setupVersion setup)---- --------------------------------------------------------------- * Internal SetupMethod--- --------------------------------------------------------------internalSetupMethod :: SetupRunner-internalSetupMethod verbosity options bt args = do-  info verbosity $ "Using internal setup method with build-type " ++ show bt-                ++ " and args:\n  " ++ show args-  inDir (useWorkingDir options) $ do-    withEnv "HASKELL_DIST_DIR" (useDistPref options) $-      withExtraPathEnv (useExtraPathEnv options) $-        withEnvOverrides (useExtraEnvOverrides options) $-          buildTypeAction bt args--buildTypeAction :: BuildType -> ([String] -> IO ())-buildTypeAction Simple    = Simple.defaultMainArgs-buildTypeAction Configure = Simple.defaultMainWithHooksArgs-                              Simple.autoconfUserHooks-buildTypeAction Make      = Make.defaultMainArgs-buildTypeAction Custom               = error "buildTypeAction Custom"----- | @runProcess'@ is a version of @runProcess@ where we have--- the additional option to decide whether or not we should--- delegate CTRL+C to the spawned process.-runProcess' :: FilePath                 -- ^ Filename of the executable-            -> [String]                 -- ^ Arguments to pass to executable-            -> Maybe FilePath           -- ^ Optional path to working directory-            -> Maybe [(String, String)] -- ^ Optional environment-            -> Maybe Handle             -- ^ Handle for @stdin@-            -> Maybe Handle             -- ^ Handle for @stdout@-            -> Maybe Handle             -- ^ Handle for @stderr@-            -> Bool                     -- ^ Delegate Ctrl+C ?-            -> IO ProcessHandle-runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do-  (_,_,_,ph) <--    createProcess-      (proc cmd args){ Process.cwd = mb_cwd-                     , Process.env = mb_env-                     , Process.std_in  = mbToStd mb_stdin-                     , Process.std_out = mbToStd mb_stdout-                     , Process.std_err = mbToStd mb_stderr-                     , Process.delegate_ctlc = _delegate-                     }-  return ph-  where-    mbToStd :: Maybe Handle -> StdStream-    mbToStd Nothing = Inherit-    mbToStd (Just hdl) = UseHandle hdl---- --------------------------------------------------------------- * Self-Exec SetupMethod--- --------------------------------------------------------------selfExecSetupMethod :: SetupRunner-selfExecSetupMethod verbosity options bt args0 = do-  let args = ["act-as-setup",-              "--build-type=" ++ prettyShow bt,-              "--"] ++ args0-  info verbosity $ "Using self-exec internal setup method with build-type "-                 ++ show bt ++ " and args:\n  " ++ show args-  path <- getExecutablePath-  info verbosity $ unwords (path : args)-  case useLoggingHandle options of-    Nothing        -> return ()-    Just logHandle -> info verbosity $ "Redirecting build log to "-                                    ++ show logHandle--  searchpath <- programSearchPathAsPATHVar-                (map ProgramSearchPathDir (useExtraPathEnv options) ++-                 getProgramSearchPath (useProgramDb options))-  env       <- getEffectiveEnvironment $-                 [ ("PATH", Just searchpath)-                 , ("HASKELL_DIST_DIR", Just (useDistPref options))-                 ] ++ useExtraEnvOverrides options-  process <- runProcess' path args-             (useWorkingDir options) env Nothing-             (useLoggingHandle options) (useLoggingHandle options)-             (isInteractive options)-  exitCode <- waitForProcess process-  unless (exitCode == ExitSuccess) $ exitWith exitCode---- --------------------------------------------------------------- * External SetupMethod--- --------------------------------------------------------------externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)-externalSetupMethod path verbosity options _ args = do-  info verbosity $ unwords (path : args)-  case useLoggingHandle options of-    Nothing        -> return ()-    Just logHandle -> info verbosity $ "Redirecting build log to "-                                    ++ show logHandle--  -- See 'Note: win32 clean hack' above.-#ifdef mingw32_HOST_OS-  if useWin32CleanHack options then doWin32CleanHack path else doInvoke path-#else-  doInvoke path-#endif--  where-    doInvoke path' = do-      searchpath <- programSearchPathAsPATHVar-                    (map ProgramSearchPathDir (useExtraPathEnv options) ++-                      getProgramSearchPath (useProgramDb options))-      env        <- getEffectiveEnvironment $-                      [ ("PATH", Just searchpath)-                      , ("HASKELL_DIST_DIR", Just (useDistPref options))-                      ] ++ useExtraEnvOverrides options--      debug verbosity $ "Setup arguments: "++unwords args-      process <- runProcess' path' args-                  (useWorkingDir options) env Nothing-                  (useLoggingHandle options) (useLoggingHandle options)-                  (isInteractive options)-      exitCode <- waitForProcess process-      unless (exitCode == ExitSuccess) $ exitWith exitCode--#ifdef mingw32_HOST_OS-    doWin32CleanHack path' = do-      info verbosity $ "Using the Win32 clean hack."-      -- Recursively removes the temp dir on exit.-      withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->-          bracket (moveOutOfTheWay tmpDir path')-                  (maybeRestore path')-                  doInvoke--    moveOutOfTheWay tmpDir path' = do-      let newPath = tmpDir </> "setup" <.> exeExtension buildPlatform-      Win32.moveFile path' newPath-      return newPath--    maybeRestore oldPath path' = do-      let oldPathDir = takeDirectory oldPath-      oldPathDirExists <- doesDirectoryExist oldPathDir-      -- 'setup clean' didn't complete, 'dist/setup' still exists.-      when oldPathDirExists $-        Win32.moveFile path' oldPath-#endif--getExternalSetupMethod-  :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType-  -> IO (Version, SetupMethod, SetupScriptOptions)-getExternalSetupMethod verbosity options pkg bt = do-  debug verbosity $ "Using external setup method with build-type " ++ show bt-  debug verbosity $ "Using explicit dependencies: "-    ++ show (useDependenciesExclusive options)-  createDirectoryIfMissingVerbose verbosity True setupDir-  (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse-  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion-  path <- if useCachedSetupExecutable-          then getCachedSetupExecutable options'-               cabalLibVersion mCabalLibInstalledPkgId-          else compileSetupExecutable   options'-               cabalLibVersion mCabalLibInstalledPkgId False--  -- Since useWorkingDir can change the relative path, the path argument must-  -- be turned into an absolute path. On some systems, runProcess' will take-  -- path as relative to the new working directory instead of the current-  -- working directory.-  path' <- tryCanonicalizePath path--  -- See 'Note: win32 clean hack' above.-#ifdef mingw32_HOST_OS-  -- setupProgFile may not exist if we're using a cached program-  setupProgFile' <- canonicalizePathNoThrow setupProgFile-  let win32CleanHackNeeded = (useWin32CleanHack options)-                              -- Skip when a cached setup script is used.-                              && setupProgFile' `equalFilePath` path'-#else-  let win32CleanHackNeeded = False-#endif-  let options'' = options' { useWin32CleanHack = win32CleanHackNeeded }--  return (cabalLibVersion, ExternalMethod path', options'')--  where-  setupDir         = workingDir options </> useDistPref options </> "setup"-  setupVersionFile = setupDir   </> "setup" <.> "version"-  setupHs          = setupDir   </> "setup" <.> "hs"-  setupProgFile    = setupDir   </> "setup" <.> exeExtension buildPlatform-  platform         = fromMaybe buildPlatform (usePlatform options)--  useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)--  maybeGetInstalledPackages :: SetupScriptOptions -> Compiler-                            -> ProgramDb -> IO InstalledPackageIndex-  maybeGetInstalledPackages options' comp progdb =-    case usePackageIndex options' of-      Just index -> return index-      Nothing    -> getInstalledPackages verbosity-                    comp (usePackageDB options') progdb--  -- Choose the version of Cabal to use if the setup script has a dependency on-  -- Cabal, and possibly update the setup script options. The version also-  -- determines how to filter the flags to Setup.-  ---  -- We first check whether the dependency solver has specified a Cabal version.-  -- If it has, we use the solver's version without looking at the installed-  -- package index (See issue #3436). Otherwise, we pick the Cabal version by-  -- checking 'useCabalSpecVersion', then the saved version, and finally the-  -- versions available in the index.-  ---  -- The version chosen here must match the one used in 'compileSetupExecutable'-  -- (See issue #3433).-  cabalLibVersionToUse :: IO (Version, Maybe ComponentId-                             ,SetupScriptOptions)-  cabalLibVersionToUse =-    case find (isCabalPkgId . snd) (useDependencies options) of-      Just (unitId, pkgId) -> do-        let version = pkgVersion pkgId-        updateSetupScript version bt-        writeSetupVersionFile version-        return (version, Just unitId, options)-      Nothing ->-        case useCabalSpecVersion options of-          Just version -> do-            updateSetupScript version bt-            writeSetupVersionFile version-            return (version, Nothing, options)-          Nothing  -> do-            savedVer <- savedVersion-            case savedVer of-              Just version | version `withinRange` useCabalVersion 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--      writeSetupVersionFile :: Version -> IO ()-      writeSetupVersionFile version =-          writeFile setupVersionFile (show version ++ "\n")--      installedVersion :: IO (Version, Maybe InstalledPackageId-                             ,SetupScriptOptions)-      installedVersion = do-        (comp,    progdb,  options')  <- configureCompiler options-        (version, mipkgid, options'') <- installedCabalVersion options'-                                         comp progdb-        updateSetupScript version bt-        writeSetupVersionFile version-        return (version, mipkgid, 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' verbosity-      "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 options </> "Setup.hs"-      customSetupLhs  = workingDir options </> "Setup.lhs"--  updateSetupScript cabalLibVersion _ =-    rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion)--  buildTypeScript :: Version -> BS.ByteString-  buildTypeScript cabalLibVersion = case bt of-    Simple                                            -> "import Distribution.Simple; main = defaultMain\n"-    Configure | cabalLibVersion >= mkVersion [1,3,10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"-              | otherwise                             -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"-    Make                                              -> "import Distribution.Make; main = defaultMain\n"-    Custom                                            -> error "buildTypeScript Custom"--  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb-                        -> IO (Version, Maybe InstalledPackageId-                              ,SetupScriptOptions)-  installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal"-                                       && bt == Custom =-    return (packageVersion pkg, Nothing, options')-  installedCabalVersion options' compiler progdb = do-    index <- maybeGetInstalledPackages options' compiler progdb-    let cabalDepName    = mkPackageName "Cabal"-        cabalDepVersion = useCabalVersion options'-        options''       = options' { usePackageIndex = Just index }-    case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of-      []   -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg)-                 ++ "' requires Cabal library version "-                 ++ prettyShow (useCabalVersion options)-                 ++ " but no suitable version is installed."-      pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs-                  err = error "Distribution.Client.installedCabalVersion: empty version list"-              in return (packageVersion ipkginfo-                        ,Just . IPI.installedComponentId $ ipkginfo, options'')--  bestVersion :: (a -> Version) -> [a] -> a-  bestVersion f = firstMaximumBy (comparing (preference . f))-    where-      -- Like maximumBy, but picks the first maximum element instead of the-      -- last. In general, we expect the preferred version to go first in the-      -- list. For the default case, this has the effect of choosing the version-      -- installed in the user package DB instead of the global one. See #1463.-      ---      -- Note: firstMaximumBy could be written as just-      -- `maximumBy cmp . reverse`, but the problem is that the behaviour of-      -- maximumBy is not fully specified in the case when there is not a single-      -- greatest element.-      firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a-      firstMaximumBy _ []   =-        error "Distribution.Client.firstMaximumBy: empty list"-      firstMaximumBy cmp xs =  foldl1' maxBy xs-        where-          maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; }--      preference version   = (sameVersion, sameMajorVersion-                             ,stableVersion, latestVersion)-        where-          sameVersion      = version == cabalVersion-          sameMajorVersion = majorVersion version == majorVersion cabalVersion-          majorVersion     = take 2 . versionNumbers-          stableVersion    = case versionNumbers version of-                               (_:x:_) -> even x-                               _       -> False-          latestVersion    = version--  configureCompiler :: SetupScriptOptions-                    -> IO (Compiler, ProgramDb, SetupScriptOptions)-  configureCompiler options' = do-    (comp, progdb) <- case useCompiler options' of-      Just comp -> return (comp, useProgramDb options')-      Nothing   -> do (comp, _, progdb) <--                        configCompilerEx (Just GHC) Nothing Nothing-                        (useProgramDb options') verbosity-                      return (comp, progdb)-    -- Whenever we need to call configureCompiler, we also need to access the-    -- package index, so let's cache it in SetupScriptOptions.-    index <- maybeGetInstalledPackages options' comp progdb-    return (comp, progdb, options' { useCompiler      = Just comp,-                                     usePackageIndex  = Just index,-                                     useProgramDb = progdb })--  -- | 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 <- getCabalDir-    let setupCacheDir       = cabalDir </> "setup-exe-cache"-        cachedSetupProgFile = setupCacheDir-                              </> ("setup-" ++ buildTypeString ++ "-"-                                   ++ cabalVersionString ++ "-"-                                   ++ platformString ++ "-"-                                   ++ compilerVersionString)-                              <.> exeExtension buildPlatform-    return (setupCacheDir, cachedSetupProgFile)-      where-        buildTypeString       = show bt-        cabalVersionString    = "Cabal-" ++ prettyShow cabalLibVersion-        compilerVersionString = prettyShow $-                                maybe buildCompilerId compilerId-                                  $ useCompiler options'-        platformString        = prettyShow platform--  -- | Look up the setup executable in the cache; update the cache if the setup-  -- executable is not found.-  getCachedSetupExecutable :: SetupScriptOptions-                           -> Version -> Maybe InstalledPackageId-                           -> IO FilePath-  getCachedSetupExecutable options' cabalLibVersion-                           maybeCabalLibInstalledPkgId = do-    (setupCacheDir, cachedSetupProgFile) <--      cachedSetupDirAndProg options' cabalLibVersion-    cachedSetupExists <- doesFileExist cachedSetupProgFile-    if cachedSetupExists-      then debug verbosity $-           "Found cached setup executable: " ++ cachedSetupProgFile-      else criticalSection' $ do-        -- The cache may have been populated while we were waiting.-        cachedSetupExists' <- doesFileExist cachedSetupProgFile-        if cachedSetupExists'-          then debug verbosity $-               "Found cached setup executable: " ++ cachedSetupProgFile-          else do-          debug verbosity $ "Setup executable not found in the cache."-          src <- compileSetupExecutable options'-                 cabalLibVersion maybeCabalLibInstalledPkgId True-          createDirectoryIfMissingVerbose verbosity True setupCacheDir-          installExecutableFile verbosity src cachedSetupProgFile-          -- Do not strip if we're using GHCJS, since the result may be a script-          when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $-            Strip.stripExe verbosity platform (useProgramDb options')-              cachedSetupProgFile-    return cachedSetupProgFile-      where-        criticalSection' = maybe id criticalSection $ setupCacheLock options'--  -- | If the Setup.hs is out of date wrt the executable then recompile it.-  -- Currently this is GHC/GHCJS only. It should really be generalised.-  ---  compileSetupExecutable :: SetupScriptOptions-                         -> Version -> Maybe ComponentId -> Bool-                         -> IO FilePath-  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, progdb, options'') <- configureCompiler options'-      let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion-          (program, extraOpts)-            = case compilerFlavor compiler of-                      GHCJS -> (ghcjsProgram, ["-build-runner"])-                      _     -> (ghcProgram,   ["-threaded"])-          cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])-                              maybeCabalLibInstalledPkgId--          -- With 'useDependenciesExclusive' we enforce the deps specified,-          -- so only the given ones can be used. Otherwise we allow the use-          -- of packages in the ambient environment, and add on a dep on the-          -- Cabal library (unless 'useDependencies' already contains one).-          ---          -- With 'useVersionMacros' we use a version CPP macros .h file.-          ---          -- Both of these options should be enabled for packages that have-          -- opted-in and declared a custom-settup stanza.-          ---          selectedDeps | useDependenciesExclusive options'-                                   = useDependencies options'-                       | otherwise = useDependencies options' ++-                                     if any (isCabalPkgId . snd)-                                        (useDependencies options')-                                     then []-                                     else cabalDep-          addRenaming (ipid, _) =-            -- Assert 'DefUnitId' invariant-            (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))-            ,defaultRenaming)-          cppMacrosFile = setupDir </> "setup_macros.h"-          ghcOptions = mempty {-              -- Respect -v0, but don't crank up verbosity on GHC if-              -- Cabal verbosity is requested. For that, use-              -- --ghc-option=-v instead!-              ghcOptVerbosity       = Flag (min verbosity normal)-            , ghcOptMode            = Flag GhcModeMake-            , ghcOptInputFiles      = toNubListR [setupHs]-            , ghcOptOutputFile      = Flag setupProgFile-            , ghcOptObjDir          = Flag setupDir-            , ghcOptHiDir           = Flag setupDir-            , ghcOptSourcePathClear = Flag True-            , ghcOptSourcePath      = case bt of-                                      Custom -> toNubListR [workingDir options']-                                      _      -> mempty-            , ghcOptPackageDBs      = usePackageDB options''-            , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')-            , ghcOptCabal           = Flag (useDependenciesExclusive options')-            , ghcOptPackages        = toNubListR $ map addRenaming selectedDeps-            , ghcOptCppIncludes     = toNubListR [ cppMacrosFile-                                                 | useVersionMacros options' ]-            , ghcOptExtra           = extraOpts-            }-      let ghcCmdLine = renderGhcOptions compiler platform ghcOptions-      when (useVersionMacros options') $-        rewriteFileEx verbosity cppMacrosFile-          $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)-      case useLoggingHandle options of-        Nothing          -> runDbProgram verbosity program progdb ghcCmdLine--        -- If build logging is enabled, redirect compiler output to-        -- the log file.-        (Just logHandle) -> do output <- getDbProgramOutput verbosity program-                                         progdb ghcCmdLine-                               hPutStr logHandle output-    return setupProgFile---isCabalPkgId :: PackageIdentifier -> Bool-isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
− Distribution/Client/SolverInstallPlan.hs 
@@ -1,440 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.SolverInstallPlan--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org--- Stability   :  provisional--- Portability :  portable------ The 'SolverInstallPlan' is the graph of packages produced by the--- dependency solver, and specifies at the package-granularity what--- things are going to be installed.  To put it another way: the--- dependency solver produces a 'SolverInstallPlan', which is then--- consumed by various other parts of Cabal.----------------------------------------------------------------------------------module Distribution.Client.SolverInstallPlan(-  SolverInstallPlan(..),-  SolverPlanPackage,-  ResolverPackage(..),--  -- * Operations on 'SolverInstallPlan's-  new,-  toList,-  toMap,--  remove,--  showPlanIndex,-  showInstallPlan,--  -- * Checking validity of plans-  valid,-  closed,-  consistent,-  acyclic,--  -- ** Details on invalid plans-  SolverPlanProblem(..),-  showPlanProblem,-  problems,--  -- ** Querying the install plan-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-) where--import Distribution.Client.Compat.Prelude hiding (toList)-import Prelude ()--import Distribution.Package-         ( PackageIdentifier(..), Package(..), PackageName-         , HasUnitId(..), PackageId, packageVersion, packageName )-import Distribution.Types.Flag (nullFlagAssignment)-import qualified Distribution.Solver.Types.ComponentDeps as CD--import Distribution.Client.Types-         ( UnresolvedPkgLoc )-import Distribution.Version-         ( Version )--import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.ResolverPackage-import           Distribution.Solver.Types.SolverId-import           Distribution.Solver.Types.SolverPackage--import Distribution.Compat.Graph (Graph, IsNode(..))-import qualified Data.Foldable as Foldable-import qualified Data.Graph as OldGraph-import qualified Distribution.Compat.Graph as Graph-import qualified Data.Map as Map-import Data.Array ((!))--type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc--type SolverPlanIndex = Graph SolverPlanPackage--data SolverInstallPlan = SolverInstallPlan {-    planIndex      :: !SolverPlanIndex,-    planIndepGoals :: !IndependentGoals-  }-  deriving (Typeable, Generic)--{---- | Much like 'planPkgIdOf', but mapping back to full packages.-planPkgOf :: SolverInstallPlan-          -> Graph.Vertex-          -> SolverPlanPackage-planPkgOf plan v =-    case Graph.lookupKey (planIndex plan)-                         (planPkgIdOf plan v) of-      Just pkg -> pkg-      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"--}----instance Binary SolverInstallPlan-instance Structured SolverInstallPlan--showPlanIndex :: [SolverPlanPackage] -> String-showPlanIndex = intercalate "\n" . map showPlanPackage--showInstallPlan :: SolverInstallPlan -> String-showInstallPlan = showPlanIndex . toList--showPlanPackage :: SolverPlanPackage -> String-showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg)-                                            ++ " (" ++ prettyShow (installedUnitId ipkg)-                                            ++ ")"-showPlanPackage (Configured  spkg) =-    "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps-  where-    flags-        | nullFlagAssignment fa = ""-        | otherwise             = " " ++ prettyShow (solverPkgFlags spkg)-      where-        fa = solverPkgFlags spkg--    comps | null deps = ""-          | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps)-      where-        deps = CD.components (solverPkgLibDeps spkg)-             <> CD.components (solverPkgExeDeps spkg)---- | Build an installation plan from a valid set of resolved packages.----new :: IndependentGoals-    -> SolverPlanIndex-    -> Either [SolverPlanProblem] SolverInstallPlan-new indepGoals index =-  case problems indepGoals index of-    []    -> Right (SolverInstallPlan index indepGoals)-    probs -> Left probs--toList :: SolverInstallPlan -> [SolverPlanPackage]-toList = Foldable.toList . planIndex--toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage-toMap = Graph.toMap . planIndex---- | Remove packages from the install plan. This will result in an--- error if there are remaining packages that depend on any matching--- package. This is primarily useful for obtaining an install plan for--- the dependencies of a package or set of packages without actually--- installing the package itself, as when doing development.----remove :: (SolverPlanPackage -> Bool)-       -> SolverInstallPlan-       -> Either [SolverPlanProblem]-                 (SolverInstallPlan)-remove shouldRemove plan =-    new (planIndepGoals plan) newIndex-  where-    newIndex = Graph.fromDistinctList $-                 filter (not . shouldRemove) (toList plan)---- --------------------------------------------------------------- * Checking validity of plans--- ---------------------------------------------------------------- | A valid installation plan is a set of packages that is 'acyclic',--- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the--- plan has to have a valid configuration (see 'configuredPackageValid').------ * if the result is @False@ use 'problems' to get a detailed list.----valid :: IndependentGoals-      -> SolverPlanIndex-      -> Bool-valid indepGoals index =-    null $ problems indepGoals index--data SolverPlanProblem =-     PackageMissingDeps   SolverPlanPackage-                          [PackageIdentifier]-   | PackageCycle         [SolverPlanPackage]-   | PackageInconsistency PackageName [(PackageIdentifier, Version)]-   | PackageStateInvalid  SolverPlanPackage SolverPlanPackage--showPlanProblem :: SolverPlanProblem -> String-showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ prettyShow (packageId pkg)-  ++ " depends on the following packages which are missing from the plan: "-  ++ intercalate ", " (map prettyShow missingDeps)--showPlanProblem (PackageCycle cycleGroup) =-     "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (prettyShow.packageId) cycleGroup)--showPlanProblem (PackageInconsistency name inconsistencies) =-     "Package " ++ prettyShow name-  ++ " is required by several packages,"-  ++ " but they require inconsistent versions:\n"-  ++ unlines [ "  package " ++ prettyShow pkg ++ " requires "-                            ++ prettyShow (PackageIdentifier name ver)-             | (pkg, ver) <- inconsistencies ]--showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ prettyShow (packageId pkg)-  ++ " is in the " ++ showPlanState pkg-  ++ " state but it depends on package " ++ prettyShow (packageId pkg')-  ++ " which is in the " ++ showPlanState pkg'-  ++ " state"-  where-    showPlanState (PreExisting _) = "pre-existing"-    showPlanState (Configured  _)   = "configured"---- | For an invalid plan, produce a detailed list of problems as human readable--- error messages. This is mainly intended for debugging purposes.--- Use 'showPlanProblem' for a human readable explanation.----problems :: IndependentGoals-         -> SolverPlanIndex-         -> [SolverPlanProblem]-problems indepGoals index =--     [ PackageMissingDeps pkg-       (mapMaybe-         (fmap packageId . flip Graph.lookup index)-         missingDeps)-     | (pkg, missingDeps) <- Graph.broken index ]--  ++ [ PackageCycle cycleGroup-     | cycleGroup <- Graph.cycles index ]--  ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <--       dependencyInconsistencies indepGoals index ]--  ++ [ PackageStateInvalid pkg pkg'-     | pkg <- Foldable.toList index-     , Just pkg' <- map (flip Graph.lookup index)-                    (nodeNeighbors pkg)-     , not (stateDependencyRelation pkg pkg') ]----- | Compute all roots of the install plan, and verify that the transitive--- plans from those roots are all consistent.------ NOTE: This does not check for dependency cycles. Moreover, dependency cycles--- may be absent from the subplans even if the larger plan contains a dependency--- cycle. Such cycles may or may not be an issue; either way, we don't check--- for them here.-dependencyInconsistencies :: IndependentGoals-                          -> SolverPlanIndex-                          -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies indepGoals index  =-    concatMap dependencyInconsistencies' subplans-  where-    subplans :: [SolverPlanIndex]-    subplans = -- Not Graph.closure!!-               map (nonSetupClosure index)-                   (rootSets indepGoals index)---- NB: When we check for inconsistencies, packages from the setup--- scripts don't count as part of the closure (this way, we--- can build, e.g., Cabal-1.24.1 even if its setup script is--- built with Cabal-1.24.0).------ This is a best effort function that swallows any non-existent--- SolverIds.-nonSetupClosure :: SolverPlanIndex-                -> [SolverId]-                -> SolverPlanIndex-nonSetupClosure index pkgids0 = closure Graph.empty pkgids0- where-    closure completed []             = completed-    closure completed (pkgid:pkgids) =-      case Graph.lookup pkgid index of-        Nothing   -> closure completed pkgids-        Just pkg  ->-          case Graph.lookup (nodeKey pkg) completed of-            Just _  -> closure completed  pkgids-            Nothing -> closure completed' pkgids'-              where completed' = Graph.insert pkg completed-                    pkgids'    = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids---- | Compute the root sets of a plan------ A root set is a set of packages whose dependency closure must be consistent.--- This is the set of all top-level library roots (taken together normally, or--- as singletons sets if we are considering them as independent goals), along--- with all setup dependencies of all packages.-rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]]-rootSets (IndependentGoals indepGoals) index =-       if indepGoals then map (:[]) libRoots else [libRoots]-    ++ setupRoots index-  where-    libRoots = libraryRoots index---- | Compute the library roots of a plan------ The library roots are the set of packages with no reverse dependencies--- (no reverse library dependencies but also no reverse setup dependencies).-libraryRoots :: SolverPlanIndex -> [SolverId]-libraryRoots index =-    map (nodeKey . toPkgId) roots-  where-    (graph, toPkgId, _) = Graph.toGraph index-    indegree = OldGraph.indegree graph-    roots    = filter isRoot (OldGraph.vertices graph)-    isRoot v = indegree ! v == 0---- | The setup dependencies of each package in the plan-setupRoots :: SolverPlanIndex -> [[SolverId]]-setupRoots = filter (not . null)-           . map (CD.setupDeps . resolverPackageLibDeps)-           . Foldable.toList---- | Given a package index where we assume we want to use all the packages--- (use 'dependencyClosure' if you need to get such a index subset) find out--- if the dependencies within it use consistent versions of each package.--- Return all cases where multiple packages depend on different versions of--- some other package.------ Each element in the result is a package name along with the packages that--- depend on it and the versions they require. These are guaranteed to be--- distinct.----dependencyInconsistencies' :: SolverPlanIndex-                           -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies' index =-    [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids])-    | (name, ipid_map) <- Map.toList inverseIndex-    , let uses = Map.elems ipid_map-    , reallyIsInconsistent (map fst uses)-    ]-  where-    -- For each package name (of a dependency, somewhere)-    --   and each installed ID of that package-    --     the associated package instance-    --     and a list of reverse dependencies (as source IDs)-    inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId]))-    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))-      [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))])-      | -- For each package @pkg@-        pkg <- Foldable.toList index-        -- Find out which @sid@ @pkg@ depends on-      , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg)-        -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@)-      , Just dep <- [Graph.lookup sid index]-      ]--    -- If, in a single install plan, we depend on more than one version of a-    -- package, then this is ONLY okay in the (rather special) case that we-    -- depend on precisely two versions of that package, and one of them-    -- depends on the other. This is necessary for example for the base where-    -- we have base-3 depending on base-4.-    reallyIsInconsistent :: [SolverPlanPackage] -> Bool-    reallyIsInconsistent []       = False-    reallyIsInconsistent [_p]     = False-    reallyIsInconsistent [p1, p2] =-      let pid1 = nodeKey p1-          pid2 = nodeKey p2-      in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2)-      && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1)-    reallyIsInconsistent _ = True----- | The graph of packages (nodes) and dependencies (edges) must be acyclic.------ * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out---   which packages are involved in dependency cycles.----acyclic :: SolverPlanIndex -> Bool-acyclic = null . Graph.cycles---- | An installation plan is closed if for every package in the set, all of--- its dependencies are also in the set. That is, the set is closed under the--- dependency relation.------ * if the result is @False@ use 'PackageIndex.brokenPackages' to find out---   which packages depend on packages not in the index.----closed :: SolverPlanIndex -> Bool-closed = null . Graph.broken---- | An installation plan is consistent if all dependencies that target a--- single package name, target the same version.------ This is slightly subtle. It is not the same as requiring that there be at--- 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--- 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 approximation of that.------ * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to---   find out which packages are.----consistent :: SolverPlanIndex -> Bool-consistent = null . dependencyInconsistencies (IndependentGoals False)---- | The states of packages have that depend on each other must respect--- this relation. That is for very case where package @a@ depends on--- package @b@ we require that @dependencyStatesOk a b = True@.----stateDependencyRelation :: SolverPlanPackage-                        -> SolverPlanPackage-                        -> Bool-stateDependencyRelation PreExisting{}   PreExisting{}     = True--stateDependencyRelation (Configured  _) PreExisting{}     = True-stateDependencyRelation (Configured  _) (Configured  _)   = True--stateDependencyRelation _               _                 = False----- | Compute the dependency closure of a package in a install plan----dependencyClosure :: SolverInstallPlan-                  -> [SolverId]-                  -> [SolverPlanPackage]-dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan)---reverseDependencyClosure :: SolverInstallPlan-                         -> [SolverId]-                         -> [SolverPlanPackage]-reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan)---topologicalOrder :: SolverInstallPlan-                 -> [SolverPlanPackage]-topologicalOrder plan = Graph.topSort (planIndex plan)---reverseTopologicalOrder :: SolverInstallPlan-                        -> [SolverPlanPackage]-reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan)
− Distribution/Client/SourceFiles.hs 
@@ -1,167 +0,0 @@--- | Contains an @sdist@ like function which computes the source files--- that we should track to determine if a rebuild is necessary.--- Unlike @sdist@, we can operate directly on the true--- 'PackageDescription' (not flattened).------ The naming convention, roughly, is that to declare we need the--- source for some type T, you use the function needT; some functions--- need auxiliary information.------ We can only use this code for non-Custom scripts; Custom scripts--- may have arbitrary extra dependencies (esp. new preprocessors) which--- we cannot "see" easily.-module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where--import Distribution.Client.ProjectPlanning.Types-import Distribution.Client.RebuildMonad--import Distribution.Solver.Types.OptionalStanza--import Distribution.Simple.PreProcess--import Distribution.Types.PackageDescription-import Distribution.Types.Component-import Distribution.Types.ComponentRequestedSpec-import Distribution.Types.Library-import Distribution.Types.Executable-import Distribution.Types.Benchmark-import Distribution.Types.BenchmarkInterface-import Distribution.Types.TestSuite-import Distribution.Types.TestSuiteInterface-import Distribution.Types.BuildInfo-import Distribution.Types.ForeignLib--import Distribution.ModuleName--import Prelude ()-import Distribution.Client.Compat.Prelude--import System.FilePath-import qualified Data.Set as Set--needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild ()-needElaboratedConfiguredPackage elab =-    case elabPkgOrComp elab of-        ElabComponent ecomp -> needElaboratedComponent elab ecomp-        ElabPackage   epkg  -> needElaboratedPackage   elab epkg--needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild ()-needElaboratedPackage elab epkg =-    traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)-  where-    pkg_descr = elabPkgDescription elab-    enabled_stanzas = pkgStanzasEnabled epkg-    -- TODO: turn this into a helper function somewhere-    enabled =-        ComponentRequestedSpec {-            testsRequested      = TestStanzas  `Set.member` enabled_stanzas,-            benchmarksRequested = BenchStanzas `Set.member` enabled_stanzas-        }--needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild ()-needElaboratedComponent elab ecomp =-    case mb_comp of-        Nothing   -> needSetup-        Just comp -> needComponent pkg_descr comp-  where-    pkg_descr = elabPkgDescription elab-    mb_comp   = fmap (getComponent pkg_descr) (compComponentName ecomp)--needComponent :: PackageDescription -> Component -> Rebuild ()-needComponent pkg_descr comp =-    case comp of-        CLib lib     -> needLibrary    pkg_descr lib-        CFLib flib   -> needForeignLib pkg_descr flib-        CExe exe     -> needExecutable pkg_descr exe-        CTest test   -> needTestSuite  pkg_descr test-        CBench bench -> needBenchmark  pkg_descr bench--needSetup :: Rebuild ()-needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return ()--needLibrary :: PackageDescription -> Library -> Rebuild ()-needLibrary pkg_descr (Library { exposedModules = modules-                               , signatures     = sigs-                               , libBuildInfo   = bi })-  = needBuildInfo pkg_descr bi (modules ++ sigs)--needForeignLib :: PackageDescription -> ForeignLib -> Rebuild ()-needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs-                                     , foreignLibBuildInfo = bi })-  = do traverse_ needIfExists fs-       needBuildInfo pkg_descr bi []--needExecutable :: PackageDescription -> Executable -> Rebuild ()-needExecutable pkg_descr (Executable { modulePath = mainPath-                                     , buildInfo  = bi })-  = do needBuildInfo pkg_descr bi []-       needMainFile  bi mainPath--needTestSuite :: PackageDescription -> TestSuite -> Rebuild ()-needTestSuite pkg_descr t-  = case testInterface t of-      TestSuiteExeV10 _ mainPath -> do-        needBuildInfo pkg_descr bi []-        needMainFile  bi mainPath-      TestSuiteLibV09 _ m ->-        needBuildInfo pkg_descr bi [m]-      TestSuiteUnsupported _ -> return () -- soft fail- where-  bi = testBuildInfo t--needMainFile :: BuildInfo -> FilePath -> Rebuild ()-needMainFile bi mainPath = do-    -- The matter here is subtle.  It might *seem* that we-    -- should just search for mainPath, but as per-    -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is'-    -- will actually be the source file AFTER preprocessing,-    -- whereas we need to get the file *prior* to preprocessing.-    ppFile <- findFileWithExtensionMonitored-                (ppSuffixes knownSuffixHandlers)-                (hsSourceDirs bi)-                (dropExtension mainPath)-    case ppFile of-        -- But check the original path in the end, because-        -- maybe it's a non-preprocessed file with a non-traditional-        -- extension.-        Nothing -> findFileMonitored (hsSourceDirs bi) mainPath-                    >>= maybe (return ()) need-        Just pp -> need pp--needBenchmark :: PackageDescription -> Benchmark -> Rebuild ()-needBenchmark pkg_descr bm-  = case benchmarkInterface bm of-     BenchmarkExeV10 _ mainPath -> do-       needBuildInfo pkg_descr bi []-       needMainFile  bi mainPath-     BenchmarkUnsupported _ -> return () -- soft fail- where-  bi = benchmarkBuildInfo bm--needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild ()-needBuildInfo pkg_descr bi modules = do-    -- NB: These are separate because there may be both A.hs and-    -- A.hs-boot; need to track both.-    findNeededModules ["hs", "lhs", "hsig", "lhsig"]-    findNeededModules ["hs-boot", "lhs-boot"]-    traverse_ needIfExists $ concat-        [ cSources bi-        , cxxSources bi-        , jsSources bi-        , cmmSources bi-        , asmSources bi-        , extraSrcFiles pkg_descr-        ]-    for_ (installIncludes bi) $ \f ->-        findFileMonitored ("." : includeDirs bi) f-            >>= maybe (return ()) need-  where-    findNeededModules exts = traverse_-        (findNeededModule exts)-        (modules ++ otherModules bi)-    findNeededModule exts m =-        findFileWithExtensionMonitored-            (ppSuffixes knownSuffixHandlers ++ exts)-            (hsSourceDirs bi)-            (toFilePath m)-          >>= maybe (return ()) need
− Distribution/Client/SrcDist.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Utilities to implemenet cabal @v2-sdist@.-module Distribution.Client.SrcDist (-    allPackageSourceFiles,-    packageDirToSdist,-)  where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Control.Monad.State.Lazy  (StateT, evalStateT, gets, modify)-import Control.Monad.Trans       (liftIO)-import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)-import System.FilePath           (normalise, takeDirectory, (</>))--import Distribution.Client.Utils                     (tryFindAddSourcePackageDesc)-import Distribution.Package                          (Package (packageId))-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)-import Distribution.Simple.PreProcess                (knownSuffixHandlers)-import Distribution.Simple.SrcDist                   (listPackageSources)-import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie)-import Distribution.Simple.Utils                     (die')-import Distribution.Types.GenericPackageDescription  (GenericPackageDescription)--import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Compression.GZip  as GZip-import qualified Data.ByteString         as BS-import qualified Data.ByteString.Lazy    as BSL-import qualified Data.Set                as Set---- | List all source files of a given add-source dependency. Exits with error if--- something is wrong (e.g. there is no .cabal file in the given directory).------ Used in sandbox and projectbuilding.--- TODO: when sandboxes are removed, move to ProjectBuilding.----allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]-allPackageSourceFiles verbosity packageDir = do-  pd <- do-    let err = "Error reading source files of package."-    desc <- tryFindAddSourcePackageDesc verbosity packageDir err-    flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc--  listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers---- | Create a tarball for a package in a directory-packageDirToSdist-    :: Verbosity-    -> GenericPackageDescription  -- ^ read in GPD-    -> FilePath                   -- ^ directory containing that GPD-    -> IO BSL.ByteString          -- ^ resulting sdist tarball-packageDirToSdist verbosity gpd dir = do-    files' <- listPackageSources verbosity dir (flattenPackageDescription gpd) knownSuffixHandlers-    let files = nub $ sort $ map normalise files'--    let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()-        entriesM = do-            let prefix = prettyShow (packageId gpd)-            modify (Set.insert prefix)-            case Tar.toTarPath True prefix of-                Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)-                Right path -> tell [Tar.directoryEntry path]--            for_ files $ \file -> do-                let fileDir = takeDirectory (prefix </> file)-                needsEntry <- gets (Set.notMember fileDir)--                when needsEntry $ do-                    modify (Set.insert fileDir)-                    case Tar.toTarPath True fileDir of-                        Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)-                        Right path -> tell [Tar.directoryEntry path]--                contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file-                case Tar.toTarPath False (prefix </> file) of-                    Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)-                    Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]--    entries <- execWriterT (evalStateT entriesM mempty)-    let -- Pretend our GZip file is made on Unix.-        normalize bs = BSL.concat [pfx, "\x03", rest']-            where-                (pfx, rest) = BSL.splitAt 9 bs-                rest' = BSL.tail rest-        -- The Unix epoch, which is the default value, is-        -- unsuitable because it causes unpacking problems on-        -- Windows; we need a post-1980 date. One gigasecond-        -- after the epoch is during 2001-09-09, so that does-        -- nicely. See #5596.-        setModTime entry = entry { Tar.entryTime = 1000000000 }-    return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
− Distribution/Client/Store.hs 
@@ -1,276 +0,0 @@-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}----- | Management for the installed package store.----module Distribution.Client.Store (--    -- * The store layout-    StoreDirLayout(..),-    defaultStoreDirLayout,--    -- * Reading store entries-    getStoreEntries,-    doesStoreEntryExist,--    -- * Creating store entries-    newStoreEntry,-    NewStoreEntryOutcome(..),--    -- * Concurrency strategy-    -- $concurrency-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import           Distribution.Client.DistDirLayout-import           Distribution.Client.RebuildMonad--import           Distribution.Package (UnitId, mkUnitId)-import           Distribution.Compiler (CompilerId)--import           Distribution.Simple.Utils-                   ( withTempDirectory, debug, info )-import           Distribution.Verbosity-                   ( silent )--import qualified Data.Set as Set-import           Control.Exception-import           System.FilePath-import           System.Directory--#ifdef MIN_VERSION_lukko-import Lukko-#else-import System.IO (openFile, IOMode(ReadWriteMode), hClose)-import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))-#if MIN_VERSION_base(4,11,0)-import GHC.IO.Handle.Lock (hUnlock)-#endif-#endif---- $concurrency------ We access and update the store concurrently. Our strategy to do that safely--- is as follows.------ The store entries once created are immutable. This alone simplifies matters--- considerably.------ Additionally, the way 'UnitId' hashes are constructed means that if a store--- entry exists already then we can assume its content is ok to reuse, rather--- than having to re-recreate. This is the nix-style input hashing concept.------ A consequence of this is that with a little care it is /safe/ to race--- updates against each other. Consider two independent concurrent builds that--- both want to build a particular 'UnitId', where that entry does not yet--- exist in the store. It is safe for both to build and try to install this--- entry into the store provided that:------ * only one succeeds--- * the looser discovers that they lost, they abandon their own build and---   re-use the store entry installed by the winner.------ Note that because builds are not reproducible in general (nor even--- necessarily ABI compatible) then it is essential that the loser abandon--- their build and use the one installed by the winner, so that subsequent--- packages are built against the exact package from the store rather than some--- morally equivalent package that may not be ABI compatible.------ Our overriding goal is that store reads be simple, cheap and not require--- locking. We will derive our write-side protocol to make this possible.------ The read-side protocol is simply:------ * check for the existence of a directory entry named after the 'UnitId' in---   question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then---   the store entry can be assumed to be complete and immutable.------ Given our read-side protocol, the final step on the write side must be to--- atomically rename a fully-formed store entry directory into its final--- location. While this will indeed be the final step, the preparatory steps--- are more complicated. The tricky aspect is that the store also contains a--- number of shared package databases (one per compiler version). Our read--- strategy means that by the time we install the store dir entry the package--- db must already have been updated. We cannot do the package db update--- as part of atomically renaming the store entry directory however. Furthermore--- it is not safe to allow either package db update because the db entry--- contains the ABI hash and this is not guaranteed to be deterministic. So we--- must register the new package prior to the atomic dir rename. Since this--- combination of steps are not atomic then we need locking.------ The write-side protocol is:------ * Create a unique temp dir and write all store entry files into it.------ * Take a lock named after the 'UnitId' in question.------ * Once holding the lock, check again for the existence of the final store---   entry directory. If the entry exists then the process lost the race and it---   must abandon, unlock and re-use the existing store entry. If the entry---   does not exist then the process won the race and it can proceed.------ * Register the package into the package db. Note that the files are not in---   their final location at this stage so registration file checks may need---   to be disabled.------ * Atomically rename the temp dir to the final store entry location.------ * Release the previously-acquired lock.------ Obviously this means it is possible to fail after registering but before--- installing the store entry, leaving a dangling package db entry. This is not--- much of a problem because this entry does not determine package existence--- for cabal. It does mean however that the package db update should be insert--- or replace, i.e. not failing if the db entry already exists.----- | Check if a particular 'UnitId' exists in the store.----doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool-doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid =-    doesDirectoryExist (storePackageDirectory compid unitid)----- | Return the 'UnitId's of all packages\/components already installed in the--- store.----getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)-getStoreEntries StoreDirLayout{storeDirectory} compid = do-    paths <- getDirectoryContentsMonitored (storeDirectory compid)-    return $! mkEntries paths-  where-    mkEntries     = Set.delete (mkUnitId "package.db")-                  . Set.delete (mkUnitId "incoming")-                  . Set.fromList-                  . map mkUnitId-                  . filter valid-    valid ('.':_) = False-    valid _       = True----- | The outcome of 'newStoreEntry': either the store entry was newly created--- or it existed already. The latter case happens if there was a race between--- two builds of the same store entry.----data NewStoreEntryOutcome = UseNewStoreEntry-                          | UseExistingStoreEntry-  deriving (Eq, Show)---- | Place a new entry into the store. See the concurrency strategy description--- for full details.------ In particular, it takes two actions: one to place files into a temporary--- location, and a second to perform any necessary registration. The first--- action is executed without any locks held (the temp dir is unique). The--- second action holds a lock that guarantees that only one cabal process is--- able to install this store entry. This means it is safe to register into--- the compiler package DB or do other similar actions.------ Note that if you need to use the registration information later then you--- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry'--- then you must read the existing registration information (unless your--- registration information is constructed fully deterministically).----newStoreEntry :: Verbosity-              -> StoreDirLayout-              -> CompilerId-              -> UnitId-              -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files.-              -> IO ()                     -- ^ Register action, if necessary.-              -> IO NewStoreEntryOutcome-newStoreEntry verbosity storeDirLayout@StoreDirLayout{..}-              compid unitid-              copyFiles register =-    -- See $concurrency above for an explanation of the concurrency protocol--    withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do--      -- Write all store entry files within the temp dir and return the prefix.-      (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir--      -- Take a lock named after the 'UnitId' in question.-      withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do--        -- Check for the existence of the final store entry directory.-        exists <- doesStoreEntryExist storeDirLayout compid unitid--        if exists-          -- If the entry exists then we lost the race and we must abandon,-          -- unlock and re-use the existing store entry.-          then do-            info verbosity $-                "Concurrent build race: abandoning build in favour of existing "-             ++ "store entry " ++ prettyShow compid </> prettyShow unitid-            return UseExistingStoreEntry--          -- If the entry does not exist then we won the race and can proceed.-          else do--            -- Register the package into the package db (if appropriate).-            register--            -- Atomically rename the temp dir to the final store entry location.-            renameDirectory incomingEntryDir finalEntryDir-            for_ otherFiles $ \file -> do-              let finalStoreFile = storeDirectory compid </> makeRelative (incomingTmpDir </> (dropDrive (storeDirectory compid))) file-              createDirectoryIfMissing True (takeDirectory finalStoreFile)-              renameFile file finalStoreFile--            debug verbosity $-              "Installed store entry " ++ prettyShow compid </> prettyShow unitid-            return UseNewStoreEntry-  where-    finalEntryDir = storePackageDirectory compid unitid---withTempIncomingDir :: StoreDirLayout -> CompilerId-                    -> (FilePath -> IO a) -> IO a-withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do-    createDirectoryIfMissing True incomingDir-    withTempDirectory silent incomingDir "new" action-  where-    incomingDir = storeIncomingDirectory compid---withIncomingUnitIdLock :: Verbosity -> StoreDirLayout-                       -> CompilerId -> UnitId-                       -> IO a -> IO a-withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock}-                       compid unitid action =-    bracket takeLock releaseLock (\_hnd -> action)-  where-#ifdef MIN_VERSION_lukko-    takeLock-        | fileLockingSupported = do-            fd <- fdOpen (storeIncomingLock compid unitid)-            gotLock <- fdTryLock fd ExclusiveLock-            unless gotLock  $ do-                info verbosity $ "Waiting for file lock on store entry "-                              ++ prettyShow compid </> prettyShow unitid-                fdLock fd ExclusiveLock-            return fd--        -- if there's no locking, do nothing. Be careful on AIX.-        | otherwise = return undefined -- :(--    releaseLock fd-        | fileLockingSupported = do-            fdUnlock fd-            fdClose fd-        | otherwise = return ()-#else-    takeLock = do-      h <- openFile (storeIncomingLock compid unitid) ReadWriteMode-      -- First try non-blocking, but if we would have to wait then-      -- log an explanation and do it again in blocking mode.-      gotlock <- hTryLock h ExclusiveLock-      unless gotlock $ do-        info verbosity $ "Waiting for file lock on store entry "-                      ++ prettyShow compid </> prettyShow unitid-        hLock h ExclusiveLock-      return h--    releaseLock h = hUnlock h >> hClose h-#endif
− Distribution/Client/Tar.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Tar--- Copyright   :  (c) 2007 Bjorn Bringert,---                    2008 Andrea Vezzosi,---                    2008-2009 Duncan Coutts--- License     :  BSD3------ Maintainer  :  duncan@community.haskell.org--- Portability :  portable------ Reading, writing and manipulating \"@.tar@\" archive files.----------------------------------------------------------------------------------module Distribution.Client.Tar (-  -- * @tar.gz@ operations-  createTarGzFile,-  extractTarGzFile,--  -- * Other local utils-  buildTreeRefTypeCode,-  buildTreeSnapshotTypeCode,-  isBuildTreeRefTypeCode,-  filterEntries,-  filterEntriesM,-  entriesToList,-  ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Data.ByteString.Lazy    as BS-import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Codec.Archive.Tar.Check as Tar-import qualified Codec.Compression.GZip  as GZip-import qualified Distribution.Client.GZipUtils as GZipUtils---- for foldEntries...-import Control.Exception (throw)------- * High level operations-----createTarGzFile :: FilePath  -- ^ Full Tarball path-                -> FilePath  -- ^ Base directory-                -> FilePath  -- ^ Directory to archive, relative to base dir-                -> IO ()-createTarGzFile tar base dir =-  BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]--extractTarGzFile :: FilePath -- ^ Destination directory-                 -> FilePath -- ^ Expected subdir (to check for tarbombs)-                 -> FilePath -- ^ Tarball-                -> IO ()-extractTarGzFile dir expected tar =-  Tar.unpack dir . Tar.checkTarbomb expected . Tar.read-  . GZipUtils.maybeDecompress =<< BS.readFile tar--instance (Exception a, Exception b) => Exception (Either a b) where-  toException (Left  e) = toException e-  toException (Right e) = toException e--  fromException e =-    case fromException e of-      Just e' -> Just (Left e')-      Nothing -> case fromException e of-                   Just e' -> Just (Right e')-                   Nothing -> Nothing----- | Type code for the local build tree reference entry type. We don't use the--- symbolic link entry type because it allows only 100 ASCII characters for the--- path.-buildTreeRefTypeCode :: Tar.TypeCode-buildTreeRefTypeCode = 'C'---- | Type code for the local build tree snapshot entry type.-buildTreeSnapshotTypeCode :: Tar.TypeCode-buildTreeSnapshotTypeCode = 'S'---- | Is this a type code for a build tree reference?-isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool-isBuildTreeRefTypeCode typeCode-  | (typeCode == buildTreeRefTypeCode-     || typeCode == buildTreeSnapshotTypeCode) = True-  | otherwise                                  = False--filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e-filterEntries p =-  Tar.foldEntries-    (\e es -> if p e then Tar.Next e es else es)-    Tar.Done-    Tar.Fail--filterEntriesM :: Monad m => (Tar.Entry -> m Bool)-               -> Tar.Entries e -> m (Tar.Entries e)-filterEntriesM p =-  Tar.foldEntries-    (\entry rest -> do-         keep <- p entry-         xs   <- rest-         if keep-           then return (Tar.Next entry xs)-           else return xs)-    (return Tar.Done)-    (return . Tar.Fail)--entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]-entriesToList = Tar.foldEntries (:) [] throw-
− Distribution/Client/TargetProblem.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Client.TargetProblem (-    TargetProblem(..),-    TargetProblem',-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Client.ProjectPlanning    (AvailableTarget)-import Distribution.Client.TargetSelector     (SubComponentTarget, TargetSelector)-import Distribution.Package                   (PackageId, PackageName)-import Distribution.Simple.LocalBuildInfo     (ComponentName (..))-import Distribution.Types.UnqualComponentName (UnqualComponentName)---- | Target problems that occur during project orchestration.-data TargetProblem a-    = TargetNotInProject                   PackageName-    | TargetAvailableInIndex               PackageName--    | TargetComponentNotProjectLocal-      PackageId ComponentName SubComponentTarget--    | TargetComponentNotBuildable-      PackageId ComponentName SubComponentTarget--    | TargetOptionalStanzaDisabledByUser-      PackageId ComponentName SubComponentTarget--    | TargetOptionalStanzaDisabledBySolver-      PackageId ComponentName SubComponentTarget--    | TargetProblemUnknownComponent-      PackageName (Either UnqualComponentName ComponentName)--    | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]-      -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable--    | TargetProblemNoTargets TargetSelector-      -- ^ There are no targets at all--    -- The target matching stuff only returns packages local to the project,-    -- so these lookups should never fail, but if 'resolveTargets' is called-    -- directly then of course it can.-    | TargetProblemNoSuchPackage           PackageId-    | TargetProblemNoSuchComponent         PackageId ComponentName--      -- | A custom target problem-    | CustomTargetProblem a-  deriving (Eq, Show, Functor)---- | Type alias for a 'TargetProblem' with no user-defined problems/errors.------ Can use the utilities below for reporting/rendering problems.-type TargetProblem' = TargetProblem Void
− Distribution/Client/TargetSelector.hs 
@@ -1,2490 +0,0 @@-{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor,-             RecordWildCards, NamedFieldPuns #-}--- TODO-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.TargetSelector--- Copyright   :  (c) Duncan Coutts 2012, 2015, 2016--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org------ Handling for user-specified target selectors.----------------------------------------------------------------------------------module Distribution.Client.TargetSelector (--    -- * Target selectors-    TargetSelector(..),-    TargetImplicitCwd(..),-    ComponentKind(..),-    ComponentKindFilter,-    SubComponentTarget(..),-    QualLevel(..),-    componentKind,--    -- * Reading target selectors-    readTargetSelectors,-    TargetSelectorProblem(..),-    reportTargetSelectorProblems,-    showTargetSelector,-    TargetString(..),-    showTargetString,-    parseTargetString,-    -- ** non-IO-    readTargetSelectorsWith,-    DirActions(..),-    defaultDirActions,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Package-         ( Package(..), PackageId, PackageName, packageName )-import Distribution.Types.UnqualComponentName-         ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName-         , packageNameToUnqualComponentName )-import Distribution.Client.Types-         ( PackageLocation(..), PackageSpecifier(..) )--import Distribution.PackageDescription-         ( PackageDescription-         , Executable(..)-         , TestSuite(..), TestSuiteInterface(..), testModules-         , Benchmark(..), BenchmarkInterface(..), benchmarkModules-         , BuildInfo(..), explicitLibModules, exeModules )-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )-import Distribution.Solver.Types.SourcePackage-         ( SourcePackage(..) )-import Distribution.ModuleName-         ( ModuleName, toFilePath )-import Distribution.Simple.LocalBuildInfo-         ( Component(..), ComponentName(..), LibraryName(..)-         , pkgComponents, componentName, componentBuildInfo )-import Distribution.Types.ForeignLib--import Distribution.Simple.Utils-         ( die', lowercase, ordNub )-import Distribution.Client.Utils-         ( makeRelativeCanonical )--import Data.List-         ( stripPrefix, groupBy )-import qualified Data.List.NonEmpty as NE-import qualified Data.Map.Lazy   as Map.Lazy-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import Control.Arrow ((&&&))-import Control.Monad-  hiding ( mfilter )-import qualified Distribution.Deprecated.ReadP as Parse-import Distribution.Deprecated.ReadP-         ( (+++), (<++) )-import Distribution.Deprecated.ParseUtils-         ( readPToMaybe )-import System.FilePath as FilePath-         ( takeExtension, dropExtension-         , splitDirectories, joinPath, splitPath )-import qualified System.Directory as IO-         ( doesFileExist, doesDirectoryExist, canonicalizePath-         , getCurrentDirectory )-import System.FilePath-         ( (</>), (<.>), normalise, dropTrailingPathSeparator )-import Text.EditDistance-         ( defaultEditCosts, restrictedDamerauLevenshteinDistance )--import qualified Prelude (foldr1)---- --------------------------------------------------------------- * Target selector terms--- ---------------------------------------------------------------- | A target selector is expression selecting a set of components (as targets--- for a actions like @build@, @run@, @test@ etc). A target selector--- corresponds to the user syntax for referring to targets on the command line.------ From the users point of view a target can be many things: packages, dirs,--- component names, files etc. Internally we consider a target to be a specific--- component (or module\/file within a component), and all the users' notions--- of targets are just different ways of referring to these component targets.------ So target selectors are expressions in the sense that they are interpreted--- to refer to one or more components. For example a 'TargetPackage' gets--- interpreted differently by different commands to refer to all or a subset--- of components within the package.------ The syntax has lots of optional parts:------ > [ package name | package dir | package .cabal file ]--- > [ [lib:|exe:] component name ]--- > [ module name | source file ]----data TargetSelector =--     -- | One (or more) packages as a whole, or all the components of a-     -- particular kind within the package(s).-     ---     -- These are always packages that are local to the project. In the case-     -- that there is more than one, they all share the same directory location.-     ---     TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter)--     -- | A package specified by name. This may refer to @extra-packages@ from-     -- the @cabal.project@ file, or a dependency of a known project package or-     -- could refer to a package from a hackage archive. It needs further-     -- context to resolve to a specific package.-     ---   | TargetPackageNamed PackageName (Maybe ComponentKindFilter)--     -- | All packages, or all components of a particular kind in all packages.-     ---   | TargetAllPackages (Maybe ComponentKindFilter)--     -- | A specific component in a package within the project.-     ---   | TargetComponent PackageId ComponentName SubComponentTarget--     -- | A component in a package, but where it cannot be verified that the-     -- package has such a component, or because the package is itself not-     -- known.-     ---   | TargetComponentUnknown PackageName-                            (Either UnqualComponentName ComponentName)-                            SubComponentTarget-  deriving (Eq, Ord, Show, Generic)---- | Does this 'TargetPackage' selector arise from syntax referring to a--- package in the current directory (e.g. @tests@ or no giving no explicit--- target at all) or does it come from syntax referring to a package name--- or location.----data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed-  deriving (Eq, Ord, Show, Generic)--data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind-  deriving (Eq, Ord, Enum, Show)--type ComponentKindFilter = ComponentKind---- | Either the component as a whole or detail about a file or module target--- within a component.----data SubComponentTarget =--     -- | The component as a whole-     WholeComponent--     -- | A specific module within a component.-   | ModuleTarget ModuleName--     -- | A specific file within a component. Note that this does not carry the-     -- file extension.-   | FileTarget   FilePath-  deriving (Eq, Ord, Show, Generic)--instance Binary SubComponentTarget-instance Structured SubComponentTarget----- --------------------------------------------------------------- * Top level, do everything--- ----------------------------------------------------------------- | Parse a bunch of command line args as 'TargetSelector's, failing with an--- error if any are unrecognised. The possible target selectors are based on--- the available packages (and their locations).----readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]-                    -> Maybe ComponentKindFilter-                    -- ^ This parameter is used when there are ambiguous selectors.-                    --   If it is 'Just', then we attempt to resolve ambiguitiy-                    --   by applying it, since otherwise there is no way to allow-                    --   contextually valid yet syntactically ambiguous selectors.-                    --   (#4676, #5461)-                    -> [String]-                    -> IO (Either [TargetSelectorProblem] [TargetSelector])-readTargetSelectors = readTargetSelectorsWith defaultDirActions--readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m-                        -> [PackageSpecifier (SourcePackage (PackageLocation a))]-                        -> Maybe ComponentKindFilter-                        -> [String]-                        -> m (Either [TargetSelectorProblem] [TargetSelector])-readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs =-    case parseTargetStrings targetStrs of-      ([], usertargets) -> do-        usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets-        knowntargets <- getKnownTargets dirActions pkgs-        case resolveTargetSelectors knowntargets usertargets' mfilter of-          ([], btargets) -> return (Right btargets)-          (problems, _)  -> return (Left problems)-      (strs, _)          -> return (Left (map TargetSelectorUnrecognised strs))---data DirActions m = DirActions {-       doesFileExist       :: FilePath -> m Bool,-       doesDirectoryExist  :: FilePath -> m Bool,-       canonicalizePath    :: FilePath -> m FilePath,-       getCurrentDirectory :: m FilePath-     }--defaultDirActions :: DirActions IO-defaultDirActions =-    DirActions {-      doesFileExist       = IO.doesFileExist,-      doesDirectoryExist  = IO.doesDirectoryExist,-      -- Workaround for <https://github.com/haskell/directory/issues/63>-      canonicalizePath    = IO.canonicalizePath . dropTrailingPathSeparator,-      getCurrentDirectory = IO.getCurrentDirectory-    }--makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath-makeRelativeToCwd DirActions{..} path =-    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory----- --------------------------------------------------------------- * Parsing target strings--- ---------------------------------------------------------------- | The outline parse of a target selector. It takes one of the forms:------ > str1--- > str1:str2--- > str1:str2:str3--- > str1:str2:str3:str4----data TargetString =-     TargetString1 String-   | TargetString2 String String-   | TargetString3 String String String-   | TargetString4 String String String String-   | TargetString5 String String String String String-   | TargetString7 String String String String String String String-  deriving (Show, Eq)---- | Parse a bunch of 'TargetString's (purely without throwing exceptions).----parseTargetStrings :: [String] -> ([String], [TargetString])-parseTargetStrings =-    partitionEithers-  . map (\str -> maybe (Left str) Right (parseTargetString str))--parseTargetString :: String -> Maybe TargetString-parseTargetString =-    readPToMaybe parseTargetApprox-  where-    parseTargetApprox :: Parse.ReadP r TargetString-    parseTargetApprox =-          (do a <- tokenQ-              return (TargetString1 a))-      +++ (do a <- tokenQ0-              _ <- Parse.char ':'-              b <- tokenQ-              return (TargetString2 a b))-      +++ (do a <- tokenQ0-              _ <- Parse.char ':'-              b <- tokenQ-              _ <- Parse.char ':'-              c <- tokenQ-              return (TargetString3 a b c))-      +++ (do a <- tokenQ0-              _ <- Parse.char ':'-              b <- token-              _ <- Parse.char ':'-              c <- tokenQ-              _ <- Parse.char ':'-              d <- tokenQ-              return (TargetString4 a b c d))-      +++ (do a <- tokenQ0-              _ <- Parse.char ':'-              b <- token-              _ <- Parse.char ':'-              c <- tokenQ-              _ <- Parse.char ':'-              d <- tokenQ-              _ <- Parse.char ':'-              e <- tokenQ-              return (TargetString5 a b c d e))-      +++ (do a <- tokenQ0-              _ <- Parse.char ':'-              b <- token-              _ <- Parse.char ':'-              c <- tokenQ-              _ <- Parse.char ':'-              d <- tokenQ-              _ <- Parse.char ':'-              e <- tokenQ-              _ <- Parse.char ':'-              f <- tokenQ-              _ <- Parse.char ':'-              g <- tokenQ-              return (TargetString7 a b c d e f g))--    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')-    tokenQ = parseHaskellString <++ token-    token0 = Parse.munch (\x -> not (isSpace x) && x /= ':')-    tokenQ0= parseHaskellString <++ token0-    parseHaskellString :: Parse.ReadP r String-    parseHaskellString = Parse.readS_to_P reads----- | Render a 'TargetString' back as the external syntax. This is mainly for--- error messages.----showTargetString :: TargetString -> String-showTargetString = intercalate ":" . components-  where-    components (TargetString1 s1)          = [s1]-    components (TargetString2 s1 s2)       = [s1,s2]-    components (TargetString3 s1 s2 s3)    = [s1,s2,s3]-    components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4]-    components (TargetString5 s1 s2 s3 s4 s5)       = [s1,s2,s3,s4,s5]-    components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7]--showTargetSelector :: TargetSelector -> String-showTargetSelector ts =-  case [ t | ql <- [QL1 .. QLFull]-           , t  <- renderTargetSelector ql ts ]-  of (t':_) -> showTargetString (forgetFileStatus t')-     [] -> ""--showTargetSelectorKind :: TargetSelector -> String-showTargetSelectorKind bt = case bt of-  TargetPackage TargetExplicitNamed _ Nothing  -> "package"-  TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter"-  TargetPackage TargetImplicitCwd   _ Nothing  -> "cwd-package"-  TargetPackage TargetImplicitCwd   _ (Just _) -> "cwd-package:filter"-  TargetPackageNamed                _ Nothing  -> "named-package"-  TargetPackageNamed                _ (Just _) -> "named-package:filter"-  TargetAllPackages Nothing                    -> "package *"-  TargetAllPackages (Just _)                   -> "package *:filter"-  TargetComponent        _ _ WholeComponent    -> "component"-  TargetComponent        _ _ ModuleTarget{}    -> "module"-  TargetComponent        _ _ FileTarget{}      -> "file"-  TargetComponentUnknown _ _ WholeComponent    -> "unknown-component"-  TargetComponentUnknown _ _ ModuleTarget{}    -> "unknown-module"-  TargetComponentUnknown _ _ FileTarget{}      -> "unknown-file"----- --------------------------------------------------------------- * Checking if targets exist as files--- --------------------------------------------------------------data TargetStringFileStatus =-     TargetStringFileStatus1 String FileStatus-   | TargetStringFileStatus2 String FileStatus String-   | TargetStringFileStatus3 String FileStatus String String-   | TargetStringFileStatus4 String String String String-   | TargetStringFileStatus5 String String String String String-   | TargetStringFileStatus7 String String String String String String String-  deriving (Eq, Ord, Show)--data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath-                | FileStatusExistsDir  FilePath -- the canonicalised filepath-                | FileStatusNotExists  Bool -- does the parent dir exist even?-  deriving (Eq, Ord, Show)--noFileStatus :: FileStatus-noFileStatus = FileStatusNotExists False--getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m-                          -> TargetString -> m TargetStringFileStatus-getTargetStringFileStatus DirActions{..} t =-    case t of-      TargetString1 s1 ->-        (\f1 -> TargetStringFileStatus1 s1 f1)          <$> fileStatus s1-      TargetString2 s1 s2 ->-        (\f1 -> TargetStringFileStatus2 s1 f1 s2)       <$> fileStatus s1-      TargetString3 s1 s2 s3 ->-        (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3)    <$> fileStatus s1-      TargetString4 s1 s2 s3 s4 ->-        return (TargetStringFileStatus4 s1 s2 s3 s4)-      TargetString5 s1 s2 s3 s4 s5 ->-        return (TargetStringFileStatus5 s1 s2 s3 s4 s5)-      TargetString7 s1 s2 s3 s4 s5 s6 s7 ->-        return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7)-  where-    fileStatus f = do-      fexists <- doesFileExist f-      dexists <- doesDirectoryExist f-      case splitPath f of-        _ | fexists -> FileStatusExistsFile <$> canonicalizePath f-          | dexists -> FileStatusExistsDir  <$> canonicalizePath f-        (d:_)       -> FileStatusNotExists  <$> doesDirectoryExist d-        _           -> pure (FileStatusNotExists False)--forgetFileStatus :: TargetStringFileStatus -> TargetString-forgetFileStatus t = case t of-    TargetStringFileStatus1 s1 _          -> TargetString1 s1-    TargetStringFileStatus2 s1 _ s2       -> TargetString2 s1 s2-    TargetStringFileStatus3 s1 _ s2 s3    -> TargetString3 s1 s2 s3-    TargetStringFileStatus4 s1   s2 s3 s4 -> TargetString4 s1 s2 s3 s4-    TargetStringFileStatus5 s1   s2 s3 s4-                                       s5 -> TargetString5 s1 s2 s3 s4 s5-    TargetStringFileStatus7 s1   s2 s3 s4-                                 s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7--getFileStatus :: TargetStringFileStatus -> Maybe FileStatus-getFileStatus (TargetStringFileStatus1 _ f)     = Just f-getFileStatus (TargetStringFileStatus2 _ f _)   = Just f-getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f-getFileStatus _                                 = Nothing--setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus-setFileStatus f (TargetStringFileStatus1 s1 _)       = TargetStringFileStatus1 s1 f-setFileStatus f (TargetStringFileStatus2 s1 _ s2)    = TargetStringFileStatus2 s1 f s2-setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3-setFileStatus _ t                                    = t--copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus-copyFileStatus src dst =-    case getFileStatus src of-      Just f -> setFileStatus f dst-      Nothing -> dst---- --------------------------------------------------------------- * Resolving target strings to target selectors--- ----------------------------------------------------------------- | Given a bunch of user-specified targets, try to resolve what it is they--- refer to.----resolveTargetSelectors :: KnownTargets-                       -> [TargetStringFileStatus]-                       -> Maybe ComponentKindFilter-                       -> ([TargetSelectorProblem],-                           [TargetSelector])--- default local dir target if there's no given target:-resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ =-    ([TargetSelectorNoTargetsInProject], [])--resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ =-    ([TargetSelectorNoTargetsInCwd], [])--resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ =-    ([], [TargetPackage TargetImplicitCwd pkgids Nothing])-  where-    pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ]--resolveTargetSelectors knowntargets targetStrs mfilter =-    partitionEithers-  . map (resolveTargetSelector knowntargets mfilter)-  $ targetStrs--resolveTargetSelector :: KnownTargets-                      -> Maybe ComponentKindFilter-                      -> TargetStringFileStatus-                      -> Either TargetSelectorProblem TargetSelector-resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =-    case findMatch (matcher targetStrStatus) of--      Unambiguous _-        | projectIsEmpty -> Left TargetSelectorNoTargetsInProject--      Unambiguous (TargetPackage TargetImplicitCwd [] _)-                         -> Left (TargetSelectorNoCurrentPackage targetStr)--      Unambiguous target -> Right target--      None errs-        | projectIsEmpty       -> Left TargetSelectorNoTargetsInProject-        | otherwise            -> Left (classifyMatchErrors errs)--      Ambiguous _          targets-        | Just kfilter <- mfilter-        , [target] <- applyKindFilter kfilter targets -> Right target--      Ambiguous exactMatch targets ->-        case disambiguateTargetSelectors-               matcher targetStrStatus exactMatch-               targets of-          Right targets'   -> Left (TargetSelectorAmbiguous targetStr targets')-          Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms)-          Left []          -> internalError "resolveTargetSelector"-  where-    matcher = matchTargetSelector knowntargets--    targetStr = forgetFileStatus targetStrStatus--    projectIsEmpty = null knownPackagesAll--    classifyMatchErrors errs-      | Just expectedNE <- NE.nonEmpty expected-      = let (things, got:|_) = NE.unzip expectedNE in-        TargetSelectorExpected targetStr (NE.toList things) got--      | not (null nosuch)-      = TargetSelectorNoSuch targetStr nosuch--      | otherwise-      = internalError $ "classifyMatchErrors: " ++ show errs-      where-        expected = [ (thing, got)-                   | (_, MatchErrorExpected thing got)-                           <- map (innerErr Nothing) errs ]-        -- Trim the list of alternatives by dropping duplicates and-        -- retaining only at most three most similar (by edit distance) ones.-        nosuch   = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $-          [ ((inside, thing, got), Set.fromList alts)-          | (inside, MatchErrorNoSuch thing got alts)-            <- map (innerErr Nothing) errs-          ]--        genResults (inside, thing, got) alts acc = (-            inside-          , thing-          , got-          , take maxResults-            $ map fst-            $ takeWhile distanceLow-            $ sortBy (comparing snd)-            $ map addLevDist-            $ Set.toList alts-          ) : acc-          where-            addLevDist = id &&& restrictedDamerauLevenshteinDistance-                                defaultEditCosts got--            distanceLow (_, dist) = dist < length got `div` 2--            maxResults = 3--        innerErr _ (MatchErrorIn kind thing m)-                     = innerErr (Just (kind,thing)) m-        innerErr c m = (c,m)--    applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector]-    applyKindFilter kfilter = filter go-      where-        go (TargetPackage      _ _ (Just filter')) = kfilter == filter'-        go (TargetPackageNamed _   (Just filter')) = kfilter == filter'-        go (TargetAllPackages      (Just filter')) = kfilter == filter'-        go (TargetComponent _ cname _)-          | CLibName    _ <- cname                 = kfilter == LibKind-          | CFLibName   _ <- cname                 = kfilter == FLibKind-          | CExeName    _ <- cname                 = kfilter == ExeKind-          | CTestName   _ <- cname                 = kfilter == TestKind-          | CBenchName  _ <- cname                 = kfilter == BenchKind-        go _                                       = True---- | The various ways that trying to resolve a 'TargetString' to a--- 'TargetSelector' can fail.----data TargetSelectorProblem-   = TargetSelectorExpected TargetString [String]  String-     -- ^  [expected thing] (actually got)-   | TargetSelectorNoSuch  TargetString-                           [(Maybe (String, String), String, String, [String])]-     -- ^ [([in thing], no such thing,  actually got, alternatives)]-   | TargetSelectorAmbiguous  TargetString-                              [(TargetString, TargetSelector)]--   | MatchingInternalError TargetString TargetSelector-                           [(TargetString, [TargetSelector])]-   | TargetSelectorUnrecognised String-     -- ^ Syntax error when trying to parse a target string.-   | TargetSelectorNoCurrentPackage TargetString-   | TargetSelectorNoTargetsInCwd-   | TargetSelectorNoTargetsInProject-  deriving (Show, Eq)---- | Qualification levels.--- Given the filepath src/F, executable component A, and package foo:-data QualLevel = QL1    -- ^ @src/F@-               | QL2    -- ^ @foo:src/F | A:src/F@-               | QL3    -- ^ @foo:A:src/F | exe:A:src/F@-               | QLFull -- ^ @pkg:foo:exe:A:file:src/F@-  deriving (Eq, Enum, Show)--disambiguateTargetSelectors-  :: (TargetStringFileStatus -> Match TargetSelector)-  -> TargetStringFileStatus -> MatchClass-  -> [TargetSelector]-  -> Either [(TargetSelector, [(TargetString, [TargetSelector])])]-            [(TargetString, TargetSelector)]-disambiguateTargetSelectors matcher matchInput exactMatch matchResults =-    case partitionEithers results of-      (errs@(_:_), _) -> Left errs-      ([], ok)        -> Right ok-  where-    -- So, here's the strategy. We take the original match results, and make a-    -- table of all their renderings at all qualification levels.-    -- Note there can be multiple renderings at each qualification level.--    -- Note that renderTargetSelector won't immediately work on any file syntax-    -- When rendering syntax, the FileStatus is always FileStatusNotExists,-    -- which will never match on syntaxForm1File!-    -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile.-    -- So we need to copy over the file status from the input-    -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus-    matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])]-    matchResultsRenderings =-      [ (matchResult, matchRenderings)-      | matchResult <- matchResults-      , let matchRenderings =-              [ copyFileStatus matchInput rendering-              | ql <- [QL1 .. QLFull]-              , rendering <- renderTargetSelector ql matchResult ]-      ]--    -- Of course the point is that we're looking for renderings that are-    -- unambiguous matches. So we build another memo table of all the matches-    -- for all of those renderings. So by looking up in this table we can see-    -- if we've got an unambiguous match.--    memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector)-    memoisedMatches =-        -- avoid recomputing the main one if it was an exact match-        (if exactMatch == Exact-           then Map.insert matchInput (Match Exact 0 matchResults)-           else id)-      $ Map.Lazy.fromList-        -- (matcher rendering) should *always* be a Match! Otherwise we will hit-        -- the internal error later on.-          [ (rendering, matcher rendering)-          | rendering <- concatMap snd matchResultsRenderings ]--    -- Finally, for each of the match results, we go through all their-    -- possible renderings (in order of qualification level, though remember-    -- there can be multiple renderings per level), and find the first one-    -- that has an unambiguous match.-    results :: [Either (TargetSelector, [(TargetString, [TargetSelector])])-                       (TargetString, TargetSelector)]-    results =-      [ case findUnambiguous originalMatch matchRenderings of-          Just unambiguousRendering ->-            Right ( forgetFileStatus unambiguousRendering-                  , originalMatch)--          -- This case is an internal error, but we bubble it up and report it-          Nothing ->-            Left  ( originalMatch-                  , [ (forgetFileStatus rendering, matches)-                    | rendering <- matchRenderings-                    , let Match m _ matches =-                            memoisedMatches Map.! rendering-                    , m /= Inexact-                    ] )--      | (originalMatch, matchRenderings) <- matchResultsRenderings ]--    findUnambiguous :: TargetSelector-                    -> [TargetStringFileStatus]-                    -> Maybe TargetStringFileStatus-    findUnambiguous _ []     = Nothing-    findUnambiguous t (r:rs) =-      case memoisedMatches Map.! r of-        Match Exact _ [t'] | t == t'-                          -> Just r-        Match Exact   _ _ -> findUnambiguous t rs-        Match Unknown _ _ -> findUnambiguous t rs-        Match Inexact _ _ -> internalError "Match Inexact"-        NoMatch       _ _ -> internalError "NoMatch"--internalError :: String -> a-internalError msg =-  error $ "TargetSelector: internal error: " ++ msg----- | Throw an exception with a formatted message if there are any problems.----reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a-reportTargetSelectorProblems verbosity problems = do--    case [ str | TargetSelectorUnrecognised str <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [ "Unrecognised target syntax for '" ++ name ++ "'."-          | name <- targets ]--    case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of-      [] -> return ()-      ((target, originalMatch, renderingsAndMatches):_) ->-        die' verbosity $ "Internal error in target matching. It should always "-           ++ "be possible to find a syntax that's sufficiently qualified to "-           ++ "give an unambiguous match. However when matching '"-           ++ showTargetString target ++ "'  we found "-           ++ showTargetSelector originalMatch-           ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does "-           ++ "not have an unambiguous syntax. The possible syntax and the "-           ++ "targets they match are as follows:\n"-           ++ unlines-                [ "'" ++ showTargetString rendering ++ "' which matches "-                  ++ intercalate ", "-                       [ showTargetSelector match ++-                         " (" ++ showTargetSelectorKind match ++ ")"-                       | match <- matches ]-                | (rendering, matches) <- renderingsAndMatches ]--    case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [    "Unrecognised target '" ++ showTargetString target-            ++ "'.\n"-            ++ "Expected a " ++ intercalate " or " expected-            ++ ", rather than '" ++ got ++ "'."-          | (target, expected, got) <- targets ]--    case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [ "Unknown target '" ++ showTargetString target ++-            "'.\n" ++ unlines-            [    (case inside of-                    Just (kind, "")-                            -> "The " ++ kind ++ " has no "-                    Just (kind, thing)-                            -> "The " ++ kind ++ " " ++ thing ++ " has no "-                    Nothing -> "There is no ")-              ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"-                                    | (thing, got, _alts) <- nosuch' ] ++ "."-              ++ if null alternatives then "" else-                 "\nPerhaps you meant " ++ intercalate ";\nor "-                 [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?"-                 | (thing, alts) <- alternatives ]-            | (inside, nosuch') <- groupByContainer nosuch-            , let alternatives =-                    [ (thing, alts)-                    | (thing,_got,alts@(_:_)) <- nosuch' ]-            ]-          | (target, nosuch) <- targets-          , let groupByContainer =-                    map (\g@((inside,_,_,_):_) ->-                            (inside, [   (thing,got,alts)-                                     | (_,thing,got,alts) <- g ]))-                  . groupBy ((==)    `on` (\(x,_,_,_) -> x))-                  . sortBy  (compare `on` (\(x,_,_,_) -> x))-          ]-        where-          mungeThing "file" = "file target"-          mungeThing thing  = thing--    case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of-      []      -> return ()-      targets ->-        die' verbosity $ unlines-          [    "Ambiguous target '" ++ showTargetString target-            ++ "'. It could be:\n "-            ++ unlines [ "   "++ showTargetString ut ++-                         " (" ++ showTargetSelectorKind bt ++ ")"-                       | (ut, bt) <- amb ]-          | (target, amb) <- targets ]--    case [ t | TargetSelectorNoCurrentPackage t <- problems ] of-      []       -> return ()-      target:_ ->-        die' verbosity $-            "The target '" ++ showTargetString target ++ "' refers to the "-         ++ "components in the package in the current directory, but there "-         ++ "is no package in the current directory (or at least not listed "-         ++ "as part of the project)."-        --TODO: report a different error if there is a .cabal file but it's-        -- not a member of the project--    case [ () | TargetSelectorNoTargetsInCwd <- problems ] of-      []  -> return ()-      _:_ ->-        die' verbosity $-            "No targets given and there is no package in the current "-         ++ "directory. Use the target 'all' for all packages in the "-         ++ "project or specify packages or components by name or location. "-         ++ "See 'cabal build --help' for more details on target options."--    case [ () | TargetSelectorNoTargetsInProject <- problems ] of-      []  -> return ()-      _:_ ->-        die' verbosity $-            "There is no <pkgname>.cabal package file or cabal.project file. "-         ++ "To build packages locally you need at minimum a <pkgname>.cabal "-         ++ "file. You can use 'cabal init' to create one.\n"-         ++ "\n"-         ++ "For non-trivial projects you will also want a cabal.project "-         ++ "file in the root directory of your project. This file lists the "-         ++ "packages in your project and all other build configuration. "-         ++ "See the Cabal user guide for full details."--    fail "reportTargetSelectorProblems: internal error"---------------------------------------- Syntax type------- | Syntax for the 'TargetSelector': the matcher and renderer----data Syntax = Syntax QualLevel Matcher Renderer-            | AmbiguousAlternatives Syntax Syntax-            | ShadowingAlternatives Syntax Syntax--type Matcher  = TargetStringFileStatus -> Match TargetSelector-type Renderer = TargetSelector -> [TargetStringFileStatus]--foldSyntax :: (a -> a -> a) -> (a -> a -> a)-           -> (QualLevel -> Matcher -> Renderer -> a)-           -> (Syntax -> a)-foldSyntax ambiguous unambiguous syntax = go-  where-    go (Syntax ql match render)    = syntax ql match render-    go (AmbiguousAlternatives a b) = ambiguous   (go a) (go b)-    go (ShadowingAlternatives a b) = unambiguous (go a) (go b)---------------------------------------- Top level renderer and matcher-----renderTargetSelector :: QualLevel -> TargetSelector-                     -> [TargetStringFileStatus]-renderTargetSelector ql ts =-    foldSyntax-      (++) (++)-      (\ql' _ render -> guard (ql == ql') >> render ts)-      syntax-  where-    syntax = syntaxForms emptyKnownTargets-                         -- don't need known targets for rendering--matchTargetSelector :: KnownTargets-                    -> TargetStringFileStatus-                    -> Match TargetSelector-matchTargetSelector knowntargets = \usertarget ->-    nubMatchesBy (==) $--    let ql = targetQualLevel usertarget in-    foldSyntax-      (<|>) (<//>)-      (\ql' match _ -> guard (ql == ql') >> match usertarget)-      syntax-  where-    syntax = syntaxForms knowntargets--    targetQualLevel TargetStringFileStatus1{} = QL1-    targetQualLevel TargetStringFileStatus2{} = QL2-    targetQualLevel TargetStringFileStatus3{} = QL3-    targetQualLevel TargetStringFileStatus4{} = QLFull-    targetQualLevel TargetStringFileStatus5{} = QLFull-    targetQualLevel TargetStringFileStatus7{} = QLFull---------------------------------------- Syntax forms------- | All the forms of syntax for 'TargetSelector'.----syntaxForms :: KnownTargets -> Syntax-syntaxForms KnownTargets {-              knownPackagesAll       = pinfo,-              knownPackagesPrimary   = ppinfo,-              knownComponentsAll     = cinfo,-              knownComponentsPrimary = pcinfo,-              knownComponentsOther   = ocinfo-            } =-    -- The various forms of syntax here are ambiguous in many cases.-    -- Our policy is by default we expose that ambiguity and report-    -- ambiguous matches. In certain cases we override the ambiguity-    -- by having some forms shadow others.-    ---    -- We make modules shadow files because module name "Q" clashes-    -- with file "Q" with no extension but these refer to the same-    -- thing anyway so it's not a useful ambiguity. Other cases are-    -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q".--    ambiguousAlternatives-        -- convenient single-component forms-      [ shadowingAlternatives-          [ ambiguousAlternatives-              [ syntaxForm1All-              , syntaxForm1Filter        ppinfo-              , shadowingAlternatives-                  [ syntaxForm1Component pcinfo-                  , syntaxForm1Package   pinfo-                  ]-              ]-          , syntaxForm1Component ocinfo-          , syntaxForm1Module    cinfo-          , syntaxForm1File      pinfo-          ]--        -- two-component partially qualified forms-        -- fully qualified form for 'all'-      , syntaxForm2MetaAll-      , syntaxForm2AllFilter-      , syntaxForm2NamespacePackage pinfo-      , syntaxForm2PackageComponent pinfo-      , syntaxForm2PackageFilter    pinfo-      , syntaxForm2KindComponent    cinfo-      , shadowingAlternatives-          [ syntaxForm2PackageModule   pinfo-          , syntaxForm2PackageFile     pinfo-          ]-      , shadowingAlternatives-          [ syntaxForm2ComponentModule cinfo-          , syntaxForm2ComponentFile   cinfo-          ]--        -- rarely used partially qualified forms-      , syntaxForm3PackageKindComponent   pinfo-      , shadowingAlternatives-          [ syntaxForm3PackageComponentModule pinfo-          , syntaxForm3PackageComponentFile   pinfo-          ]-      , shadowingAlternatives-          [ syntaxForm3KindComponentModule    cinfo-          , syntaxForm3KindComponentFile      cinfo-          ]-      , syntaxForm3NamespacePackageFilter pinfo--        -- fully-qualified forms for all and cwd with filter-      , syntaxForm3MetaAllFilter-      , syntaxForm3MetaCwdFilter ppinfo--        -- fully-qualified form for package and package with filter-      , syntaxForm3MetaNamespacePackage       pinfo-      , syntaxForm4MetaNamespacePackageFilter pinfo--        -- fully-qualified forms for component, module and file-      , syntaxForm5MetaNamespacePackageKindComponent                pinfo-      , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo-      , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile   pinfo-      ]-  where-    ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives-    shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives----- | Syntax: "all" to select all packages in the project------ > cabal build all----syntaxForm1All :: Syntax-syntaxForm1All =-  syntaxForm1 render $ \str1 _fstatus1 -> do-    guardMetaAll str1-    return (TargetAllPackages Nothing)-  where-    render (TargetAllPackages Nothing) =-      [TargetStringFileStatus1 "all" noFileStatus]-    render _ = []---- | Syntax: filter------ > cabal build tests----syntaxForm1Filter :: [KnownPackage] -> Syntax-syntaxForm1Filter ps =-  syntaxForm1 render $ \str1 _fstatus1 -> do-    kfilter <- matchComponentKindFilter str1-    return (TargetPackage TargetImplicitCwd pids (Just kfilter))-  where-    pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]-    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =-      [TargetStringFileStatus1 (dispF kfilter) noFileStatus]-    render _ = []----- | Syntax: package (name, dir or file)------ > cabal build foo--- > cabal build ../bar ../bar/bar.cabal----syntaxForm1Package :: [KnownPackage] -> Syntax-syntaxForm1Package pinfo =-  syntaxForm1 render $ \str1 fstatus1 -> do-    guardPackage            str1 fstatus1-    p <- matchPackage pinfo str1 fstatus1-    case p of-      KnownPackage{pinfoId} ->-        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)-      KnownPackageName pn ->-        return (TargetPackageNamed pn Nothing)-  where-    render (TargetPackage TargetExplicitNamed [p] Nothing) =-      [TargetStringFileStatus1 (dispP p) noFileStatus]-    render (TargetPackageNamed pn Nothing) =-      [TargetStringFileStatus1 (dispPN pn) noFileStatus]-    render _ = []---- | Syntax: component------ > cabal build foo----syntaxForm1Component :: [KnownComponent] -> Syntax-syntaxForm1Component cs =-  syntaxForm1 render $ \str1 _fstatus1 -> do-    guardComponentName str1-    c <- matchComponentName cs str1-    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)-  where-    render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus1 (dispC p c) noFileStatus]-    render _ = []---- | Syntax: module------ > cabal build Data.Foo----syntaxForm1Module :: [KnownComponent] -> Syntax-syntaxForm1Module cs =-  syntaxForm1 render $  \str1 _fstatus1 -> do-    guardModuleName str1-    let ms = [ (m,c) | c <- cs, m <- cinfoModules c ]-    (m,c) <- matchModuleNameAnd ms str1-    return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m))-  where-    render (TargetComponent _p _c (ModuleTarget m)) =-      [TargetStringFileStatus1 (dispM m) noFileStatus]-    render _ = []---- | Syntax: file name------ > cabal build Data/Foo.hs bar/Main.hsc----syntaxForm1File :: [KnownPackage] -> Syntax-syntaxForm1File ps =-    -- Note there's a bit of an inconsistency here vs the other syntax forms-    -- for files. For the single-part syntax the target has to point to a file-    -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for-    -- all the other forms we don't require that.-  syntaxForm1 render $ \str1 fstatus1 ->-    expecting "file" str1 $ do-    (pkgfile, ~KnownPackage{pinfoId, pinfoComponents})-      -- always returns the KnownPackage case-      <- matchPackageDirectoryPrefix ps fstatus1-    orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-      (filepath, c) <- matchComponentFile pinfoComponents pkgfile-      return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))-  where-    render (TargetComponent _p _c (FileTarget f)) =-      [TargetStringFileStatus1 f noFileStatus]-    render _ = []--------- | Syntax:  :all------ > cabal build :all----syntaxForm2MetaAll :: Syntax-syntaxForm2MetaAll =-  syntaxForm2 render $ \str1 _fstatus1 str2 -> do-    guardNamespaceMeta str1-    guardMetaAll str2-    return (TargetAllPackages Nothing)-  where-    render (TargetAllPackages Nothing) =-      [TargetStringFileStatus2 "" noFileStatus "all"]-    render _ = []---- | Syntax:  all : filer------ > cabal build all:tests----syntaxForm2AllFilter :: Syntax-syntaxForm2AllFilter =-  syntaxForm2 render $ \str1 _fstatus1 str2 -> do-    guardMetaAll str1-    kfilter <- matchComponentKindFilter str2-    return (TargetAllPackages (Just kfilter))-  where-    render (TargetAllPackages (Just kfilter)) =-      [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)]-    render _ = []---- | Syntax:  package : filer------ > cabal build foo:tests----syntaxForm2PackageFilter :: [KnownPackage] -> Syntax-syntaxForm2PackageFilter ps =-  syntaxForm2 render $ \str1 fstatus1 str2 -> do-    guardPackage         str1 fstatus1-    p <- matchPackage ps str1 fstatus1-    kfilter <- matchComponentKindFilter str2-    case p of-      KnownPackage{pinfoId} ->-        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))-      KnownPackageName pn ->-        return (TargetPackageNamed pn (Just kfilter))-  where-    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =-      [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)]-    render (TargetPackageNamed pn (Just kfilter)) =-      [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)]-    render _ = []---- | Syntax: pkg : package name------ > cabal build pkg:foo----syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax-syntaxForm2NamespacePackage pinfo =-  syntaxForm2 render $ \str1 _fstatus1 str2 -> do-    guardNamespacePackage   str1-    guardPackageName        str2-    p <- matchPackage pinfo str2 noFileStatus-    case p of-      KnownPackage{pinfoId} ->-        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)-      KnownPackageName pn ->-        return (TargetPackageNamed pn Nothing)-  where-    render (TargetPackage TargetExplicitNamed [p] Nothing) =-      [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)]-    render (TargetPackageNamed pn Nothing) =-      [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)]-    render _ = []---- | Syntax: package : component------ > cabal build foo:foo--- > cabal build ./foo:foo--- > cabal build ./foo.cabal:foo----syntaxForm2PackageComponent :: [KnownPackage] -> Syntax-syntaxForm2PackageComponent ps =-  syntaxForm2 render $ \str1 fstatus1 str2 -> do-    guardPackage         str1 fstatus1-    guardComponentName   str2-    p <- matchPackage ps str1 fstatus1-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentName pinfoComponents str2-          return (TargetComponent pinfoId (cinfoName c) WholeComponent)-        --TODO: the error here ought to say there's no component by that name in-        -- this package, and name the package-      KnownPackageName pn ->-        let cn = mkUnqualComponentName str2 in-        return (TargetComponentUnknown pn (Left cn) WholeComponent)-  where-    render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]-    render (TargetComponentUnknown pn (Left cn) WholeComponent) =-      [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)]-    render _ = []---- | Syntax: namespace : component------ > cabal build lib:foo exe:foo----syntaxForm2KindComponent :: [KnownComponent] -> Syntax-syntaxForm2KindComponent cs =-  syntaxForm2 render $ \str1 _fstatus1 str2 -> do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)-  where-    render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)]-    render _ = []---- | Syntax: package : module------ > cabal build foo:Data.Foo--- > cabal build ./foo:Data.Foo--- > cabal build ./foo.cabal:Data.Foo----syntaxForm2PackageModule :: [KnownPackage] -> Syntax-syntaxForm2PackageModule ps =-  syntaxForm2 render $ \str1 fstatus1 str2 -> do-    guardPackage         str1 fstatus1-    guardModuleName      str2-    p <- matchPackage ps str1 fstatus1-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ]-          (m,c) <- matchModuleNameAnd ms str2-          return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))-      KnownPackageName pn -> do-        m <- matchModuleNameUnknown str2-        -- We assume the primary library component of the package:-        return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m))-  where-    render (TargetComponent p _c (ModuleTarget m)) =-      [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)]-    render _ = []---- | Syntax: component : module------ > cabal build foo:Data.Foo----syntaxForm2ComponentModule :: [KnownComponent] -> Syntax-syntaxForm2ComponentModule cs =-  syntaxForm2 render $ \str1 _fstatus1 str2 -> do-    guardComponentName str1-    guardModuleName    str2-    c <- matchComponentName cs str1-    orNoThingIn "component" (cinfoStrName c) $ do-      let ms = cinfoModules c-      m <- matchModuleName ms str2-      return (TargetComponent (cinfoPackageId c) (cinfoName c)-                              (ModuleTarget m))-  where-    render (TargetComponent p c (ModuleTarget m)) =-      [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)]-    render _ = []---- | Syntax: package : filename------ > cabal build foo:Data/Foo.hs--- > cabal build ./foo:Data/Foo.hs--- > cabal build ./foo.cabal:Data/Foo.hs----syntaxForm2PackageFile :: [KnownPackage] -> Syntax-syntaxForm2PackageFile ps =-  syntaxForm2 render $ \str1 fstatus1 str2 -> do-    guardPackage         str1 fstatus1-    p <- matchPackage ps str1 fstatus1-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          (filepath, c) <- matchComponentFile pinfoComponents str2-          return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))-      KnownPackageName pn ->-        let filepath = str2 in-        -- We assume the primary library component of the package:-        return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath))-  where-    render (TargetComponent p _c (FileTarget f)) =-      [TargetStringFileStatus2 (dispP p) noFileStatus f]-    render _ = []---- | Syntax: component : filename------ > cabal build foo:Data/Foo.hs----syntaxForm2ComponentFile :: [KnownComponent] -> Syntax-syntaxForm2ComponentFile cs =-  syntaxForm2 render $ \str1 _fstatus1 str2 -> do-    guardComponentName str1-    c <- matchComponentName cs str1-    orNoThingIn "component" (cinfoStrName c) $ do-      (filepath, _) <- matchComponentFile [c] str2-      return (TargetComponent (cinfoPackageId c) (cinfoName c)-                              (FileTarget filepath))-  where-    render (TargetComponent p c (FileTarget f)) =-      [TargetStringFileStatus2 (dispC p c) noFileStatus f]-    render _ = []--------- | Syntax: :all : filter------ > cabal build :all:tests----syntaxForm3MetaAllFilter :: Syntax-syntaxForm3MetaAllFilter =-  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do-    guardNamespaceMeta str1-    guardMetaAll str2-    kfilter <- matchComponentKindFilter str3-    return (TargetAllPackages (Just kfilter))-  where-    render (TargetAllPackages (Just kfilter)) =-      [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)]-    render _ = []--syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax-syntaxForm3MetaCwdFilter ps =-  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do-    guardNamespaceMeta str1-    guardNamespaceCwd str2-    kfilter <- matchComponentKindFilter str3-    return (TargetPackage TargetImplicitCwd pids (Just kfilter))-  where-    pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]-    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =-      [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]-    render _ = []---- | Syntax: :pkg : package name------ > cabal build :pkg:foo----syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax-syntaxForm3MetaNamespacePackage pinfo =-  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do-    guardNamespaceMeta      str1-    guardNamespacePackage   str2-    guardPackageName        str3-    p <- matchPackage pinfo str3 noFileStatus-    case p of-      KnownPackage{pinfoId} ->-        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)-      KnownPackageName pn ->-        return (TargetPackageNamed pn Nothing)-  where-    render (TargetPackage TargetExplicitNamed [p] Nothing) =-      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)]-    render (TargetPackageNamed pn Nothing) =-      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)]-    render _ = []---- | Syntax: package : namespace : component------ > cabal build foo:lib:foo--- > cabal build foo/:lib:foo--- > cabal build foo.cabal:lib:foo----syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax-syntaxForm3PackageKindComponent ps =-  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do-    guardPackage         str1 fstatus1-    ckind <- matchComponentKind str2-    guardComponentName   str3-    p <- matchPackage ps str1 fstatus1-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentKindAndName pinfoComponents ckind str3-          return (TargetComponent pinfoId (cinfoName c) WholeComponent)-      KnownPackageName pn ->-        let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in-        return (TargetComponentUnknown pn (Right cn) WholeComponent)-  where-    render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)]-    render (TargetComponentUnknown pn (Right c) WholeComponent) =-      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)]-    render _ = []---- | Syntax: package : component : module------ > cabal build foo:foo:Data.Foo--- > cabal build foo/:foo:Data.Foo--- > cabal build foo.cabal:foo:Data.Foo----syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax-syntaxForm3PackageComponentModule ps =-  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do-    guardPackage str1 fstatus1-    guardComponentName str2-    guardModuleName    str3-    p <- matchPackage ps str1 fstatus1-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentName pinfoComponents str2-          orNoThingIn "component" (cinfoStrName c) $ do-            let ms = cinfoModules c-            m <- matchModuleName ms str3-            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))-      KnownPackageName pn -> do-        let cn = mkUnqualComponentName  str2-        m     <- matchModuleNameUnknown str3-        return (TargetComponentUnknown pn (Left cn) (ModuleTarget m))-  where-    render (TargetComponent p c (ModuleTarget m)) =-      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)]-    render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) =-      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)]-    render _ = []---- | Syntax: namespace : component : module------ > cabal build lib:foo:Data.Foo----syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax-syntaxForm3KindComponentModule cs =-  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do-    ckind <- matchComponentKind str1-    guardComponentName str2-    guardModuleName    str3-    c <- matchComponentKindAndName cs ckind str2-    orNoThingIn "component" (cinfoStrName c) $ do-      let ms = cinfoModules c-      m <- matchModuleName ms str3-      return (TargetComponent (cinfoPackageId c) (cinfoName c)-                              (ModuleTarget m))-  where-    render (TargetComponent p c (ModuleTarget m)) =-      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)]-    render _ = []---- | Syntax: package : component : filename------ > cabal build foo:foo:Data/Foo.hs--- > cabal build foo/:foo:Data/Foo.hs--- > cabal build foo.cabal:foo:Data/Foo.hs----syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax-syntaxForm3PackageComponentFile ps =-  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do-    guardPackage         str1 fstatus1-    guardComponentName   str2-    p <- matchPackage ps str1 fstatus1-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentName pinfoComponents str2-          orNoThingIn "component" (cinfoStrName c) $ do-            (filepath, _) <- matchComponentFile [c] str3-            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))-      KnownPackageName pn ->-        let cn = mkUnqualComponentName str2-            filepath = str3 in-        return (TargetComponentUnknown pn (Left cn) (FileTarget filepath))-  where-    render (TargetComponent p c (FileTarget f)) =-      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f]-    render (TargetComponentUnknown pn (Left c) (FileTarget f)) =-      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f]-    render _ = []---- | Syntax: namespace : component : filename------ > cabal build lib:foo:Data/Foo.hs----syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax-syntaxForm3KindComponentFile cs =-  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do-    ckind <- matchComponentKind str1-    guardComponentName str2-    c <- matchComponentKindAndName cs ckind str2-    orNoThingIn "component" (cinfoStrName c) $ do-      (filepath, _) <- matchComponentFile [c] str3-      return (TargetComponent (cinfoPackageId c) (cinfoName c)-                              (FileTarget filepath))-  where-    render (TargetComponent p c (FileTarget f)) =-      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f]-    render _ = []--syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax-syntaxForm3NamespacePackageFilter ps =-  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do-    guardNamespacePackage str1-    guardPackageName      str2-    p <- matchPackage  ps str2 noFileStatus-    kfilter <- matchComponentKindFilter str3-    case p of-      KnownPackage{pinfoId} ->-        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))-      KnownPackageName pn ->-        return (TargetPackageNamed pn (Just kfilter))-  where-    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =-      [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)]-    render (TargetPackageNamed pn (Just kfilter)) =-      [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)]-    render _ = []------syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax-syntaxForm4MetaNamespacePackageFilter ps =-  syntaxForm4 render $ \str1 str2 str3 str4 -> do-    guardNamespaceMeta    str1-    guardNamespacePackage str2-    guardPackageName      str3-    p <- matchPackage  ps str3 noFileStatus-    kfilter <- matchComponentKindFilter str4-    case p of-      KnownPackage{pinfoId} ->-        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))-      KnownPackageName pn ->-        return (TargetPackageNamed pn (Just kfilter))-  where-    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =-      [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)]-    render (TargetPackageNamed pn (Just kfilter)) =-      [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)]-    render _ = []---- | Syntax: :pkg : package : namespace : component------ > cabal build :pkg:foo:lib:foo----syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax-syntaxForm5MetaNamespacePackageKindComponent ps =-  syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do-    guardNamespaceMeta    str1-    guardNamespacePackage str2-    guardPackageName      str3-    ckind <- matchComponentKind str4-    guardComponentName    str5-    p <- matchPackage  ps str3 noFileStatus-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentKindAndName pinfoComponents ckind str5-          return (TargetComponent pinfoId (cinfoName c) WholeComponent)-      KnownPackageName pn ->-        let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in-        return (TargetComponentUnknown pn (Right cn) WholeComponent)-  where-    render (TargetComponent p c WholeComponent) =-      [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)]-    render (TargetComponentUnknown pn (Right c) WholeComponent) =-      [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)]-    render _ = []---- | Syntax: :pkg : package : namespace : component : module : module------ > cabal build :pkg:foo:lib:foo:module:Data.Foo----syntaxForm7MetaNamespacePackageKindComponentNamespaceModule-  :: [KnownPackage] -> Syntax-syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps =-  syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do-    guardNamespaceMeta    str1-    guardNamespacePackage str2-    guardPackageName      str3-    ckind <- matchComponentKind str4-    guardComponentName    str5-    guardNamespaceModule  str6-    p <- matchPackage  ps str3 noFileStatus-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentKindAndName pinfoComponents ckind str5-          orNoThingIn "component" (cinfoStrName c) $ do-            let ms = cinfoModules c-            m <- matchModuleName ms str7-            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))-      KnownPackageName pn -> do-        let cn = mkComponentName pn ckind (mkUnqualComponentName str2)-        m <- matchModuleNameUnknown str7-        return (TargetComponentUnknown pn (Right cn) (ModuleTarget m))-  where-    render (TargetComponent p c (ModuleTarget m)) =-      [TargetStringFileStatus7 "" "pkg" (dispP p)-                               (dispCK c) (dispC p c)-                               "module" (dispM m)]-    render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) =-      [TargetStringFileStatus7 "" "pkg" (dispPN pn)-                               (dispCK c) (dispC' pn c)-                               "module" (dispM m)]-    render _ = []---- | Syntax: :pkg : package : namespace : component : file : filename------ > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs----syntaxForm7MetaNamespacePackageKindComponentNamespaceFile-  :: [KnownPackage] -> Syntax-syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps =-  syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do-    guardNamespaceMeta    str1-    guardNamespacePackage str2-    guardPackageName      str3-    ckind <- matchComponentKind str4-    guardComponentName    str5-    guardNamespaceFile    str6-    p <- matchPackage  ps str3 noFileStatus-    case p of-      KnownPackage{pinfoId, pinfoComponents} ->-        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do-          c <- matchComponentKindAndName pinfoComponents ckind str5-          orNoThingIn "component" (cinfoStrName c) $ do-            (filepath,_) <- matchComponentFile [c] str7-            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))-      KnownPackageName pn ->-        let cn       = mkComponentName pn ckind (mkUnqualComponentName str5)-            filepath = str7 in-        return (TargetComponentUnknown pn (Right cn) (FileTarget filepath))-  where-    render (TargetComponent p c (FileTarget f)) =-      [TargetStringFileStatus7 "" "pkg" (dispP p)-                               (dispCK c) (dispC p c)-                               "file" f]-    render (TargetComponentUnknown pn (Right c) (FileTarget f)) =-      [TargetStringFileStatus7 "" "pkg" (dispPN pn)-                               (dispCK c) (dispC' pn c)-                               "file" f]-    render _ = []--------------------------------------------- Syntax utils-----type Match1 = String -> FileStatus -> Match TargetSelector-type Match2 = String -> FileStatus -> String-              -> Match TargetSelector-type Match3 = String -> FileStatus -> String -> String-              -> Match TargetSelector-type Match4 = String -> String -> String -> String-              -> Match TargetSelector-type Match5 = String -> String -> String -> String -> String-              -> Match TargetSelector-type Match7 = String -> String -> String -> String -> String -> String -> String-              -> Match TargetSelector--syntaxForm1 :: Renderer -> Match1 -> Syntax-syntaxForm2 :: Renderer -> Match2 -> Syntax-syntaxForm3 :: Renderer -> Match3 -> Syntax-syntaxForm4 :: Renderer -> Match4 -> Syntax-syntaxForm5 :: Renderer -> Match5 -> Syntax-syntaxForm7 :: Renderer -> Match7 -> Syntax--syntaxForm1 render f =-    Syntax QL1 match render-  where-    match = \(TargetStringFileStatus1 str1 fstatus1) ->-              f str1 fstatus1--syntaxForm2 render f =-    Syntax QL2 match render-  where-    match = \(TargetStringFileStatus2 str1 fstatus1 str2) ->-              f str1 fstatus1 str2--syntaxForm3 render f =-    Syntax QL3 match render-  where-    match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) ->-              f str1 fstatus1 str2 str3--syntaxForm4 render f =-    Syntax QLFull match render-  where-    match (TargetStringFileStatus4 str1 str2 str3 str4)-            = f str1 str2 str3 str4-    match _ = mzero--syntaxForm5 render f =-    Syntax QLFull match render-  where-    match (TargetStringFileStatus5 str1 str2 str3 str4 str5)-            = f str1 str2 str3 str4 str5-    match _ = mzero--syntaxForm7 render f =-    Syntax QLFull match render-  where-    match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7)-            = f str1 str2 str3 str4 str5 str6 str7-    match _ = mzero--dispP :: Package p => p -> String-dispP = prettyShow . packageName--dispPN :: PackageName -> String-dispPN = prettyShow--dispC :: PackageId -> ComponentName -> String-dispC = componentStringName . packageName--dispC' :: PackageName -> ComponentName -> String-dispC' = componentStringName--dispCN :: UnqualComponentName -> String-dispCN = prettyShow--dispK :: ComponentKind -> String-dispK = showComponentKindShort--dispCK :: ComponentName -> String-dispCK = dispK . componentKind--dispF :: ComponentKind -> String-dispF = showComponentKindFilterShort--dispM :: ModuleName -> String-dispM = prettyShow------------------------------------- Package and component info-----data KnownTargets = KnownTargets {-       knownPackagesAll       :: [KnownPackage],-       knownPackagesPrimary   :: [KnownPackage],-       knownPackagesOther     :: [KnownPackage],-       knownComponentsAll     :: [KnownComponent],-       knownComponentsPrimary :: [KnownComponent],-       knownComponentsOther   :: [KnownComponent]-     }-  deriving Show--data KnownPackage =-     KnownPackage {-       pinfoId          :: PackageId,-       pinfoDirectory   :: Maybe (FilePath, FilePath),-       pinfoPackageFile :: Maybe (FilePath, FilePath),-       pinfoComponents  :: [KnownComponent]-     }-   | KnownPackageName {-       pinfoName        :: PackageName-     }-  deriving Show--data KnownComponent = KnownComponent {-       cinfoName      :: ComponentName,-       cinfoStrName   :: ComponentStringName,-       cinfoPackageId :: PackageId,-       cinfoSrcDirs   :: [FilePath],-       cinfoModules   :: [ModuleName],-       cinfoHsFiles   :: [FilePath],   -- other hs files (like main.hs)-       cinfoCFiles    :: [FilePath],-       cinfoJsFiles   :: [FilePath]-     }-  deriving Show--type ComponentStringName = String--knownPackageName :: KnownPackage -> PackageName-knownPackageName KnownPackage{pinfoId}       = packageName pinfoId-knownPackageName KnownPackageName{pinfoName} = pinfoName--emptyKnownTargets :: KnownTargets-emptyKnownTargets = KnownTargets [] [] [] [] [] []--getKnownTargets :: (Applicative m, Monad m)-                => DirActions m-                -> [PackageSpecifier (SourcePackage (PackageLocation a))]-                -> m KnownTargets-getKnownTargets dirActions@DirActions{..} pkgs = do-    pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs-    cwd   <- getCurrentDirectory-    let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo-    return KnownTargets {-      knownPackagesAll       = pinfo,-      knownPackagesPrimary   = ppinfo,-      knownPackagesOther     = opinfo,-      knownComponentsAll     = allComponentsIn pinfo,-      knownComponentsPrimary = allComponentsIn ppinfo,-      knownComponentsOther   = allComponentsIn opinfo-    }-  where-    selectPrimaryPackage :: FilePath-                         -> [KnownPackage]-                         -> ([KnownPackage], [KnownPackage])-    selectPrimaryPackage cwd = partition isPkgDirCwd-      where-        isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) }-          | dir == cwd = True-        isPkgDirCwd _  = False-    allComponentsIn ps =-      [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ]---collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m-                        -> PackageSpecifier (SourcePackage (PackageLocation a))-                        -> m KnownPackage-collectKnownPackageInfo _ (NamedPackage pkgname _props) =-    return (KnownPackageName pkgname)-collectKnownPackageInfo dirActions@DirActions{..}-                  (SpecificSourcePackage SourcePackage {-                    srcpkgDescription = pkg,-                    srcpkgSource      = loc-                  }) = do-    (pkgdir, pkgfile) <--      case loc of-        --TODO: local tarballs, remote tarballs etc-        LocalUnpackedPackage dir -> do-          dirabs <- canonicalizePath dir-          dirrel <- makeRelativeToCwd dirActions dirabs-          --TODO: ought to get this earlier in project reading-          let fileabs = dirabs </> prettyShow (packageName pkg) <.> "cabal"-              filerel = dirrel </> prettyShow (packageName pkg) <.> "cabal"-          exists <- doesFileExist fileabs-          return ( Just (dirabs, dirrel)-                 , if exists then Just (fileabs, filerel) else Nothing-                 )-        _ -> return (Nothing, Nothing)-    let pinfo =-          KnownPackage {-            pinfoId          = packageId pkg,-            pinfoDirectory   = pkgdir,-            pinfoPackageFile = pkgfile,-            pinfoComponents  = collectKnownComponentInfo-                                 (flattenPackageDescription pkg)-          }-    return pinfo---collectKnownComponentInfo :: PackageDescription -> [KnownComponent]-collectKnownComponentInfo pkg =-    [ KnownComponent {-        cinfoName      = componentName c,-        cinfoStrName   = componentStringName (packageName pkg) (componentName c),-        cinfoPackageId = packageId pkg,-        cinfoSrcDirs   = ordNub (hsSourceDirs bi),-        cinfoModules   = ordNub (componentModules c),-        cinfoHsFiles   = ordNub (componentHsFiles c),-        cinfoCFiles    = ordNub (cSources bi),-        cinfoJsFiles   = ordNub (jsSources bi)-      }-    | c <- pkgComponents pkg-    , let bi = componentBuildInfo c ]---componentStringName :: PackageName -> ComponentName -> ComponentStringName-componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname-componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name-componentStringName _ (CFLibName name)  = unUnqualComponentName name-componentStringName _ (CExeName   name) = unUnqualComponentName name-componentStringName _ (CTestName  name) = unUnqualComponentName name-componentStringName _ (CBenchName name) = unUnqualComponentName name--componentModules :: Component -> [ModuleName]--- I think it's unlikely users will ask to build a requirement--- which is not mentioned locally.-componentModules (CLib   lib)   = explicitLibModules lib-componentModules (CFLib  flib)  = foreignLibModules flib-componentModules (CExe   exe)   = exeModules exe-componentModules (CTest  test)  = testModules test-componentModules (CBench bench) = benchmarkModules bench--componentHsFiles :: Component -> [FilePath]-componentHsFiles (CExe exe) = [modulePath exe]-componentHsFiles (CTest  TestSuite {-                           testInterface = TestSuiteExeV10 _ mainfile-                         }) = [mainfile]-componentHsFiles (CBench Benchmark {-                           benchmarkInterface = BenchmarkExeV10 _ mainfile-                         }) = [mainfile]-componentHsFiles _          = []------------------------------------ Matching meta targets-----guardNamespaceMeta :: String -> Match ()-guardNamespaceMeta = guardToken [""] "meta namespace"--guardMetaAll :: String -> Match ()-guardMetaAll = guardToken ["all"] "meta-target 'all'"--guardNamespacePackage :: String -> Match ()-guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace"--guardNamespaceCwd :: String -> Match ()-guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace"--guardNamespaceModule :: String -> Match ()-guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace"--guardNamespaceFile :: String -> Match ()-guardNamespaceFile = guardToken ["file"] "'file' namespace"--guardToken :: [String] -> String -> String -> Match ()-guardToken tokens msg s-  | caseFold s `elem` tokens = increaseConfidence-  | otherwise                = matchErrorExpected msg s------------------------------------ Matching component kinds-----componentKind :: ComponentName -> ComponentKind-componentKind (CLibName _)   = LibKind-componentKind (CFLibName _)  = FLibKind-componentKind (CExeName   _) = ExeKind-componentKind (CTestName  _) = TestKind-componentKind (CBenchName _) = BenchKind--cinfoKind :: KnownComponent -> ComponentKind-cinfoKind = componentKind . cinfoName--matchComponentKind :: String -> Match ComponentKind-matchComponentKind s-  | s' `elem` liblabels   = increaseConfidence >> return LibKind-  | s' `elem` fliblabels  = increaseConfidence >> return FLibKind-  | s' `elem` exelabels   = increaseConfidence >> return ExeKind-  | s' `elem` testlabels  = increaseConfidence >> return TestKind-  | s' `elem` benchlabels = increaseConfidence >> return BenchKind-  | otherwise             = matchErrorExpected "component kind" s-  where-    s'         = caseFold s-    liblabels   = ["lib", "library"]-    fliblabels  = ["flib", "foreign-library"]-    exelabels   = ["exe", "executable"]-    testlabels  = ["tst", "test", "test-suite"]-    benchlabels = ["bench", "benchmark"]--matchComponentKindFilter :: String -> Match ComponentKind-matchComponentKindFilter s-  | s' `elem` liblabels   = increaseConfidence >> return LibKind-  | s' `elem` fliblabels  = increaseConfidence >> return FLibKind-  | s' `elem` exelabels   = increaseConfidence >> return ExeKind-  | s' `elem` testlabels  = increaseConfidence >> return TestKind-  | s' `elem` benchlabels = increaseConfidence >> return BenchKind-  | otherwise             = matchErrorExpected "component kind filter" s-  where-    s'          = caseFold s-    liblabels   = ["libs", "libraries"]-    fliblabels  = ["flibs", "foreign-libraries"]-    exelabels   = ["exes", "executables"]-    testlabels  = ["tests", "test-suites"]-    benchlabels = ["benches", "benchmarks"]--showComponentKind :: ComponentKind -> String-showComponentKind LibKind   = "library"-showComponentKind FLibKind  = "foreign library"-showComponentKind ExeKind   = "executable"-showComponentKind TestKind  = "test-suite"-showComponentKind BenchKind = "benchmark"--showComponentKindShort :: ComponentKind -> String-showComponentKindShort LibKind   = "lib"-showComponentKindShort FLibKind  = "flib"-showComponentKindShort ExeKind   = "exe"-showComponentKindShort TestKind  = "test"-showComponentKindShort BenchKind = "bench"--showComponentKindFilterShort :: ComponentKind -> String-showComponentKindFilterShort LibKind   = "libs"-showComponentKindFilterShort FLibKind  = "flibs"-showComponentKindFilterShort ExeKind   = "exes"-showComponentKindFilterShort TestKind  = "tests"-showComponentKindFilterShort BenchKind = "benchmarks"------------------------------------ Matching package targets-----guardPackage :: String -> FileStatus -> Match ()-guardPackage str fstatus =-      guardPackageName str-  <|> guardPackageDir  str fstatus-  <|> guardPackageFile str fstatus---guardPackageName :: String -> Match ()-guardPackageName s-  | validPackageName s = increaseConfidence-  | otherwise          = matchErrorExpected "package name" s--validPackageName :: String -> Bool-validPackageName s =-       all validPackageNameChar s-    && not (null s)-  where-    validPackageNameChar c = isAlphaNum c || c == '-'---guardPackageDir :: String -> FileStatus -> Match ()-guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence-guardPackageDir str _ = matchErrorExpected "package directory" str---guardPackageFile :: String -> FileStatus -> Match ()-guardPackageFile _ (FileStatusExistsFile file)-                       | takeExtension file == ".cabal"-                       = increaseConfidence-guardPackageFile str _ = matchErrorExpected "package .cabal file" str---matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage-matchPackage pinfo = \str fstatus ->-    orNoThingIn "project" "" $-          matchPackageName pinfo str-    <//> (matchPackageNameUnknown str-     <|>  matchPackageDir  pinfo str fstatus-     <|>  matchPackageFile pinfo str fstatus)---matchPackageName :: [KnownPackage] -> String -> Match KnownPackage-matchPackageName ps = \str -> do-    guard (validPackageName str)-    orNoSuchThing "package" str-                  (map (prettyShow . knownPackageName) ps) $-      increaseConfidenceFor $-        matchInexactly caseFold (prettyShow . knownPackageName) ps str---matchPackageNameUnknown :: String -> Match KnownPackage-matchPackageNameUnknown str = do-    pn <- matchParse str-    unknownMatch (KnownPackageName pn)---matchPackageDir :: [KnownPackage]-                -> String -> FileStatus -> Match KnownPackage-matchPackageDir ps = \str fstatus ->-    case fstatus of-      FileStatusExistsDir canondir ->-        orNoSuchThing "package directory" str (map (snd . fst) dirs) $-          increaseConfidenceFor $-            fmap snd $ matchExactly (fst . fst) dirs canondir-      _ -> mzero-  where-    dirs = [ ((dabs,drel),p)-           | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ]---matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage-matchPackageFile ps = \str fstatus -> do-    case fstatus of-      FileStatusExistsFile canonfile ->-        orNoSuchThing "package .cabal file" str (map (snd . fst) files) $-          increaseConfidenceFor $-            fmap snd $ matchExactly (fst . fst) files canonfile-      _ -> mzero-  where-    files = [ ((fabs,frel),p)-            | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ]----TODO: test outcome when dir exists but doesn't match any known one----TODO: perhaps need another distinction, vs no such thing, point is the---      thing is not known, within the project, but could be outside project------------------------------------ Matching component targets------guardComponentName :: String -> Match ()-guardComponentName s-  | all validComponentChar s-    && not (null s)  = increaseConfidence-  | otherwise        = matchErrorExpected "component name" s-  where-    validComponentChar c = isAlphaNum c || c == '.'-                        || c == '_' || c == '-' || c == '\''---matchComponentName :: [KnownComponent] -> String -> Match KnownComponent-matchComponentName cs str =-    orNoSuchThing "component" str (map cinfoStrName cs)-  $ increaseConfidenceFor-  $ matchInexactly caseFold cinfoStrName cs str---matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String-                          -> Match KnownComponent-matchComponentKindAndName cs ckind str =-    orNoSuchThing (showComponentKind ckind ++ " component") str-                  (map render cs)-  $ increaseConfidenceFor-  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))-                   (\c -> (cinfoKind c, cinfoStrName c))-                   cs-                   (ckind, str)-  where-    render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c------------------------------------ Matching module targets-----guardModuleName :: String -> Match ()-guardModuleName s =-  case simpleParsec s :: Maybe ModuleName of-    Just _                   -> increaseConfidence-    _ | all validModuleChar s-        && not (null s)      -> return ()-      | otherwise            -> matchErrorExpected "module name" s-    where-      validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''---matchModuleName :: [ModuleName] -> String -> Match ModuleName-matchModuleName ms str =-    orNoSuchThing "module" str (map prettyShow ms)-  $ increaseConfidenceFor-  $ matchInexactly caseFold prettyShow ms str---matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)-matchModuleNameAnd ms str =-    orNoSuchThing "module" str (map (prettyShow . fst) ms)-  $ increaseConfidenceFor-  $ matchInexactly caseFold (prettyShow . fst) ms str---matchModuleNameUnknown :: String -> Match ModuleName-matchModuleNameUnknown str =-    expecting "module" str-  $ increaseConfidenceFor-  $ matchParse str------------------------------------ Matching file targets-----matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus-                            -> Match (FilePath, KnownPackage)-matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =-    increaseConfidenceFor $-      matchDirectoryPrefix pkgdirs filepath-  where-    pkgdirs = [ (dir, p)-              | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ]-matchPackageDirectoryPrefix _ _ = mzero---matchComponentFile :: [KnownComponent] -> String-                   -> Match (FilePath, KnownComponent)-matchComponentFile cs str =-    orNoSuchThing "file" str [] $-        matchComponentModuleFile cs str-    <|> matchComponentOtherFile  cs str---matchComponentOtherFile :: [KnownComponent] -> String-                        -> Match (FilePath, KnownComponent)-matchComponentOtherFile cs =-    matchFile-      [ (normalise (srcdir </> file), c)-      | c      <- cs-      , srcdir <- cinfoSrcDirs c-      , file   <- cinfoHsFiles c-               ++ cinfoCFiles  c-               ++ cinfoJsFiles c-      ]-      . normalise---matchComponentModuleFile :: [KnownComponent] -> String-                         -> Match (FilePath, KnownComponent)-matchComponentModuleFile cs str = do-    matchFile-      [ (normalise (d </> toFilePath m), c)-      | c <- cs-      , d <- cinfoSrcDirs c-      , m <- cinfoModules c-      ]-      (dropExtension (normalise str)) -- Drop the extension because FileTarget-                                      -- is stored without the extension---- utils--matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)-matchFile fs =-      increaseConfidenceFor-    . matchInexactly caseFold fst fs--matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)-matchDirectoryPrefix dirs filepath =-    tryEach $-      [ (file, x)-      | (dir,x) <- dirs-      , file <- maybeToList (stripDirectory dir) ]-  where-    stripDirectory :: FilePath -> Maybe FilePath-    stripDirectory dir =-      joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit--    filepathsplit = splitDirectories filepath------------------------------------ Matching monad------- | A matcher embodies a way to match some input as being some recognised--- value. In particular it deals with multiple and ambiguous matches.------ There are various matcher primitives ('matchExactly', 'matchInexactly'),--- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we--- can run a matcher against an input using 'findMatch'.----data Match a = NoMatch           !Confidence [MatchError]-             | Match !MatchClass !Confidence [a]-  deriving Show---- | The kind of match, inexact or exact. We keep track of this so we can--- prefer exact over inexact matches. The 'Ord' here is important: we try--- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom.----data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package-                          --   name without it being a specific known package-                | Inexact -- ^ Matches a known thing inexactly-                          --   e.g. matches a known package case insensitively-                | Exact   -- ^ Exactly matches a known thing,-                          --   e.g. matches a known package case sensitively-  deriving (Show, Eq, Ord)--type Confidence = Int--data MatchError = MatchErrorExpected String String            -- thing got-                | MatchErrorNoSuch   String String [String]   -- thing got alts-                | MatchErrorIn       String String MatchError -- kind  thing-  deriving (Show, Eq)---instance Functor Match where-    fmap _ (NoMatch d ms) = NoMatch d ms-    fmap f (Match m d xs) = Match m d (fmap f xs)--instance Applicative Match where-    pure a = Match Exact 0 [a]-    (<*>)  = ap--instance Alternative Match where-    empty = NoMatch 0 []-    (<|>) = matchPlus--instance Monad Match where-    return             = pure-    NoMatch d ms >>= _ = NoMatch d ms-    Match m d xs >>= f =-      -- To understand this, it needs to be read in context with the-      -- implementation of 'matchPlus' below-      case msum (map f xs) of-        Match m' d' xs' -> Match (min m m') (d + d') xs'-        -- The minimum match class is the one we keep. The match depth is-        -- tracked but not used in the Match case.--        NoMatch  d' ms  -> NoMatch          (d + d') ms-        -- Here is where we transfer the depth we were keeping track of in-        -- the Match case over to the NoMatch case where it finally gets used.--instance MonadPlus Match where-    mzero = empty-    mplus = matchPlus--(<//>) :: Match a -> Match a -> Match a-(<//>) = matchPlusShadowing--infixl 3 <//>---- | Combine two matchers. Exact matches are used over inexact matches--- but if we have multiple exact, or inexact then the we collect all the--- ambiguous matches.------ This operator is associative, has unit 'mzero' and is also commutative.----matchPlus :: Match a -> Match a -> Match a-matchPlus a@(Match _ _ _ )   (NoMatch _ _) = a-matchPlus   (NoMatch _ _ ) b@(Match _ _ _) = b-matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b)-  | d_a > d_b = a  -- We only really make use of the depth in the NoMatch case.-  | d_a < d_b = b-  | otherwise = NoMatch d_a (ms_a ++ ms_b)-matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b)-  | m_a > m_b = a  -- exact over inexact-  | m_a < m_b = b  -- exact over inexact-  | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b)---- | Combine two matchers. This is similar to 'matchPlus' with the--- difference that an exact match from the left matcher shadows any exact--- match on the right. Inexact matches are still collected however.------ This operator is associative, has unit 'mzero' and is not commutative.----matchPlusShadowing :: Match a -> Match a -> Match a-matchPlusShadowing a@(Match Exact _ _) _ = a-matchPlusShadowing a                   b = matchPlus a b------------------------------------ Various match primitives-----matchErrorExpected :: String -> String -> Match a-matchErrorExpected thing got      = NoMatch 0 [MatchErrorExpected thing got]--matchErrorNoSuch :: String -> String -> [String] -> Match a-matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts]--expecting :: String -> String -> Match a -> Match a-expecting thing got (NoMatch 0 _) = matchErrorExpected thing got-expecting _     _   m             = m--orNoSuchThing :: String -> String -> [String] -> Match a -> Match a-orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts-orNoSuchThing _     _   _    m             = m--orNoThingIn :: String -> String -> Match a -> Match a-orNoThingIn kind name (NoMatch n ms) =-    NoMatch n [ MatchErrorIn kind name m | m <- ms ]-orNoThingIn _ _ m = m--increaseConfidence :: Match ()-increaseConfidence = Match Exact 1 [()]--increaseConfidenceFor :: Match a -> Match a-increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r--nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a-nubMatchesBy _  (NoMatch d msgs) = NoMatch d msgs-nubMatchesBy eq (Match m d xs)   = Match m d (nubBy eq xs)---- | Lift a list of matches to an exact match.----exactMatches, inexactMatches :: [a] -> Match a--exactMatches [] = mzero-exactMatches xs = Match Exact 0 xs--inexactMatches [] = mzero-inexactMatches xs = Match Inexact 0 xs--unknownMatch :: a -> Match a-unknownMatch x = Match Unknown 0 [x]--tryEach :: [a] -> Match a-tryEach = exactMatches------------------------------------ Top level match runner------- | Given a matcher and a key to look up, use the matcher to find all the--- possible matches. There may be 'None', a single 'Unambiguous' match or--- you may have an 'Ambiguous' match with several possibilities.----findMatch :: Match a -> MaybeAmbiguous a-findMatch match = case match of-  NoMatch _ msgs -> None msgs-  Match _ _  [x] -> Unambiguous x-  Match m d   [] -> error $ "findMatch: impossible: " ++ show match'-                      where match' = Match m d [] :: Match ()-                    -- TODO: Maybe use Data.List.NonEmpty inside-                    -- Match so that this case would be correct-                    -- by construction?-  Match m _   xs -> Ambiguous m xs--data MaybeAmbiguous a = None [MatchError]-                      | Unambiguous a-                      | Ambiguous MatchClass [a]-  deriving Show------------------------------------ Basic matchers------- | A primitive matcher that looks up a value in a finite 'Map'. The--- value must match exactly.----matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a)-matchExactly key xs =-    \k -> case Map.lookup k m of-            Nothing -> mzero-            Just ys -> exactMatches ys-  where-    m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]---- | A primitive matcher that looks up a value in a finite 'Map'. It checks--- for an exact or inexact match. We get an inexact match if the match--- is not exact, but the canonical forms match. It takes a canonicalisation--- function for this purpose.------ So for example if we used string case fold as the canonicalisation--- function, then we would get case insensitive matching (but it will still--- report an exact match when the case matches too).----matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k)-               -> [a] -> (k -> Match a)-matchInexactly cannonicalise key xs =-    \k -> case Map.lookup k m of-            Just ys -> exactMatches ys-            Nothing -> case Map.lookup (cannonicalise k) m' of-                         Just ys -> inexactMatches ys-                         Nothing -> mzero-  where-    m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]--    -- the map of canonicalised keys to groups of inexact matches-    m' = Map.mapKeysWith (++) cannonicalise m--matchParse :: Parsec a => String -> Match a-matchParse = maybe mzero return . simpleParsec------------------------------------ Utils-----caseFold :: String -> String-caseFold = lowercase---- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the--- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's--- primary library from named private libraries.----mkComponentName :: PackageName-                -> ComponentKind-                -> UnqualComponentName-                -> ComponentName-mkComponentName pkgname ckind ucname =-  case ckind of-    LibKind-      | packageNameToUnqualComponentName pkgname == ucname-                  -> CLibName LMainLibName-      | otherwise -> CLibName $ LSubLibName ucname-    FLibKind      -> CFLibName   ucname-    ExeKind       -> CExeName    ucname-    TestKind      -> CTestName   ucname-    BenchKind     -> CBenchName  ucname------------------------------------ Example inputs-----{--ex1pinfo :: [KnownPackage]-ex1pinfo =-  [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $-    KnownPackage {-      pinfoId          = PackageIdentifier (mkPackageName "foo") (mkVersion [1]),-      pinfoDirectory   = Just ("/the/foo", "foo"),-      pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"),-      pinfoComponents  = []-    }-  , KnownPackage {-      pinfoId          = PackageIdentifier (mkPackageName "bar") (mkVersion [1]),-      pinfoDirectory   = Just ("/the/bar", "bar"),-      pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"),-      pinfoComponents  = []-    }-  ]-  where-    addComponent n ds ms p =-      p {-        pinfoComponents =-            KnownComponent n (componentStringName (pinfoId p) n)-                          p ds (map mkMn ms)-                          [] [] []-          : pinfoComponents p-      }--    mkMn :: String -> ModuleName-    mkMn  = ModuleName.fromString--}-{--stargets =-  [ TargetComponent (CExeName "foo")  WholeComponent-  , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo"))-  , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo"))-  ]-    where-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse--ex_pkgid :: PackageIdentifier-Just ex_pkgid = simpleParse "thelib"--}--{--ex_cs :: [KnownComponent]-ex_cs =-  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])-  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])-  ]-    where-    mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms)-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse-    pkgid :: PackageIdentifier-    Just pkgid = simpleParse "thelib"--}
− Distribution/Client/Targets.hs 
@@ -1,746 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Targets--- Copyright   :  (c) Duncan Coutts 2011--- License     :  BSD-like------ Maintainer  :  duncan@community.haskell.org------ Handling for user-specified targets-------------------------------------------------------------------------------module Distribution.Client.Targets (-  -- * User targets-  UserTarget(..),-  readUserTargets,--  -- * Resolving user targets to package specifiers-  resolveUserTargets,--  -- ** Detailed interface-  UserTargetProblem(..),-  readUserTarget,-  reportUserTargetProblems,-  expandUserTarget,--  PackageTarget(..),-  fetchPackageTarget,-  readPackageTarget,--  PackageTargetProblem(..),-  reportPackageTargetProblems,--  disambiguatePackageTargets,-  disambiguatePackageName,--  -- * User constraints-  UserQualifier(..),-  UserConstraintScope(..),-  UserConstraint(..),-  userConstraintPackageName,-  readUserConstraint,-  userToPackageConstraint,--  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Package-         ( Package(..), PackageName, unPackageName, mkPackageName-         , packageName )-import Distribution.Types.Dependency-import Distribution.Client.Types-         ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage-         , PackageSpecifier(..) )--import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Solver.Types.PackageConstraint-import           Distribution.Solver.Types.PackagePath-import           Distribution.Solver.Types.PackageIndex (PackageIndex)-import qualified Distribution.Solver.Types.PackageIndex as PackageIndex-import           Distribution.Solver.Types.SourcePackage--import qualified Distribution.Client.World as World-import qualified Codec.Archive.Tar       as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import qualified Distribution.Client.Tar as Tar-import Distribution.Client.FetchUtils-import Distribution.Client.Utils ( tryFindPackageDesc )-import Distribution.Client.GlobalFlags-         ( RepoContext(..) )-import Distribution.Types.PackageVersionConstraint-         ( PackageVersionConstraint (..) )--import Distribution.PackageDescription-         ( GenericPackageDescription )-import Distribution.Types.Flag-         ( nullFlagAssignment, parsecFlagAssignmentNonEmpty )-import Distribution.Version-         ( anyVersion, isAnyVersion )-import Distribution.Simple.Utils-         ( die', warn, lowercase )--import Distribution.PackageDescription.Parsec-         ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe )--import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as BS-import qualified Distribution.Client.GZipUtils as GZipUtils-import qualified Distribution.Compat.CharParsing as P-import System.FilePath-         ( takeExtension, dropExtension, takeDirectory, splitPath )-import System.Directory-         ( doesFileExist, doesDirectoryExist )-import Network.URI-         ( URI(..), URIAuth(..), parseAbsoluteURI )---- --------------------------------------------------------------- * User targets--- ---------------------------------------------------------------- | Various ways that a user may specify a package or package collection.----data UserTarget =--     -- | A partially specified package, identified by name and possibly with-     -- an exact version or a version constraint.-     ---     -- > cabal install foo-     -- > cabal install foo-1.0-     -- > cabal install 'foo < 2'-     ---     UserTargetNamed PackageVersionConstraint--     -- | A special virtual package that refers to the collection of packages-     -- recorded in the world file that the user specifically installed.-     ---     -- > cabal install world-     ---   | UserTargetWorld--     -- | A specific package that is unpacked in a local directory, often the-     -- current directory.-     ---     -- > cabal install .-     -- > cabal install ../lib/other-     ---     -- * Note: in future, if multiple @.cabal@ files are allowed in a single-     -- directory then this will refer to the collection of packages.-     ---   | UserTargetLocalDir FilePath--     -- | A specific local unpacked package, identified by its @.cabal@ file.-     ---     -- > cabal install foo.cabal-     -- > cabal install ../lib/other/bar.cabal-     ---   | UserTargetLocalCabalFile FilePath--     -- | A specific package that is available as a local tarball file-     ---     -- > cabal install dist/foo-1.0.tar.gz-     -- > cabal install ../build/baz-1.0.tar.gz-     ---   | UserTargetLocalTarball FilePath--     -- | A specific package that is available as a remote tarball file-     ---     -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz-     ---   | UserTargetRemoteTarball URI-  deriving (Show,Eq)----- --------------------------------------------------------------- * Parsing and checking user targets--- --------------------------------------------------------------readUserTargets :: Verbosity -> [String] -> IO [UserTarget]-readUserTargets verbosity targetStrs = do-    (problems, targets) <- liftM partitionEithers-                                 (traverse readUserTarget targetStrs)-    reportUserTargetProblems verbosity problems-    return targets---data UserTargetProblem-   = UserTargetUnexpectedFile      String-   | UserTargetNonexistantFile     String-   | UserTargetUnexpectedUriScheme String-   | UserTargetUnrecognisedUri     String-   | UserTargetUnrecognised        String-   | UserTargetBadWorldPkg-  deriving Show--readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)-readUserTarget targetstr =-    case eitherParsec targetstr of-      Right (PackageVersionConstraint pkgn verrange)-        | pkgn == mkPackageName "world"-          -> return $ if verrange == anyVersion-                      then Right UserTargetWorld-                      else Left  UserTargetBadWorldPkg-      Right dep -> return (Right (UserTargetNamed dep))-      Left _err -> do-        fileTarget <- testFileTargets targetstr-        case fileTarget of-          Just target -> return target-          Nothing     ->-            case testUriTargets targetstr of-              Just target -> return target-              Nothing     -> return (Left (UserTargetUnrecognised targetstr))-  where-    testFileTargets filename = do-      isDir  <- doesDirectoryExist filename-      isFile <- doesFileExist filename-      parentDirExists <- case takeDirectory filename of-                           []  -> return False-                           dir -> doesDirectoryExist dir-      let result-            | isDir-            = Just (Right (UserTargetLocalDir filename))--            | isFile && extensionIsTarGz filename-            = Just (Right (UserTargetLocalTarball filename))--            | isFile && takeExtension filename == ".cabal"-            = Just (Right (UserTargetLocalCabalFile filename))--            | isFile-            = Just (Left (UserTargetUnexpectedFile filename))--            | parentDirExists-            = Just (Left (UserTargetNonexistantFile filename))--            | otherwise-            = Nothing-      return result--    testUriTargets str =-      case parseAbsoluteURI str of-        Just uri@URI {-            uriScheme    = scheme,-            uriAuthority = Just URIAuth { uriRegName = host }-          }-          | scheme /= "http:" && scheme /= "https:" ->-            Just (Left (UserTargetUnexpectedUriScheme targetstr))--          | null host ->-            Just (Left (UserTargetUnrecognisedUri targetstr))--          | otherwise ->-            Just (Right (UserTargetRemoteTarball uri))-        _ -> Nothing--    extensionIsTarGz f = takeExtension f                 == ".gz"-                      && takeExtension (dropExtension f) == ".tar"--reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()-reportUserTargetProblems verbosity problems = do-    case [ target | UserTargetUnrecognised target <- problems ] of-      []     -> return ()-      target -> die' verbosity-              $ unlines-                  [ "Unrecognised target '" ++ name ++ "'."-                  | name <- target ]-             ++ "Targets can be:\n"-             ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"-             ++ " - the special 'world' target\n"-             ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"-             ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"--    case [ () | UserTargetBadWorldPkg <- problems ] of-      [] -> return ()-      _  -> die' verbosity "The special 'world' target does not take any version."--    case [ target | UserTargetNonexistantFile target <- problems ] of-      []     -> return ()-      target -> die' verbosity-              $ unlines-                  [ "The file does not exist '" ++ name ++ "'."-                  | name <- target ]--    case [ target | UserTargetUnexpectedFile target <- problems ] of-      []     -> return ()-      target -> die' verbosity-              $ unlines-                  [ "Unrecognised file target '" ++ name ++ "'."-                  | name <- target ]-             ++ "File targets can be either package tarballs 'pkgname.tar.gz' "-             ++ "or cabal files 'pkgname.cabal'."--    case [ target | UserTargetUnexpectedUriScheme target <- problems ] of-      []     -> return ()-      target -> die' verbosity-              $ unlines-                  [ "URL target not supported '" ++ name ++ "'."-                  | name <- target ]-             ++ "Only 'http://' and 'https://' URLs are supported."--    case [ target | UserTargetUnrecognisedUri target <- problems ] of-      []     -> return ()-      target -> die' verbosity-              $ unlines-                  [ "Unrecognise URL target '" ++ name ++ "'."-                  | name <- target ]----- --------------------------------------------------------------- * Resolving user targets to package specifiers--- ---------------------------------------------------------------- | Given a bunch of user-specified targets, try to resolve what it is they--- refer to. They can either be specific packages (local dirs, tarballs etc)--- or they can be named packages (with or without version info).----resolveUserTargets :: Package pkg-                   => Verbosity-                   -> RepoContext-                   -> FilePath-                   -> PackageIndex pkg-                   -> [UserTarget]-                   -> IO [PackageSpecifier UnresolvedSourcePackage]-resolveUserTargets verbosity repoCtxt worldFile available userTargets = do--    -- given the user targets, get a list of fully or partially resolved-    -- package references-    packageTargets <- traverse (readPackageTarget verbosity)-                  =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat-                  =<< traverse (expandUserTarget verbosity worldFile) userTargets--    -- users are allowed to give package names case-insensitively, so we must-    -- disambiguate named package references-    let (problems, packageSpecifiers) =-           disambiguatePackageTargets available availableExtra packageTargets--        -- use any extra specific available packages to help us disambiguate-        availableExtra = [ packageName pkg-                         | PackageTargetLocation pkg <- packageTargets ]--    reportPackageTargetProblems verbosity problems--    return packageSpecifiers----- --------------------------------------------------------------- * Package targets--- ---------------------------------------------------------------- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.--- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.----data PackageTarget pkg =-     PackageTargetNamed      PackageName [PackageProperty] UserTarget--     -- | A package identified by name, but case insensitively, so it needs-     -- to be resolved to the right case-sensitive name.-   | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget-   | PackageTargetLocation pkg-  deriving (Show, Functor, Foldable, Traversable)----- --------------------------------------------------------------- * Converting user targets to package targets--- ---------------------------------------------------------------- | Given a user-specified target, expand it to a bunch of package targets--- (each of which refers to only one package).----expandUserTarget :: Verbosity-                 -> FilePath-                 -> UserTarget-                 -> IO [PackageTarget (PackageLocation ())]-expandUserTarget verbosity worldFile userTarget = case userTarget of--    UserTargetNamed (PackageVersionConstraint name vrange) ->-      let props = [ PackagePropertyVersion vrange-                  | not (isAnyVersion vrange) ]-      in  return [PackageTargetNamedFuzzy name props userTarget]--    UserTargetWorld -> do-      worldPkgs <- World.getContents verbosity worldFile-      --TODO: should we warn if there are no world targets?-      return [ PackageTargetNamed name props userTarget-             | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs-             , let props = [ PackagePropertyVersion vrange-                           | not (isAnyVersion vrange) ]-                        ++ [ PackagePropertyFlags flags-                           | not (nullFlagAssignment flags) ] ]--    UserTargetLocalDir dir ->-      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]--    UserTargetLocalCabalFile file -> do-      let dir = takeDirectory file-      _   <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check-      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]--    UserTargetLocalTarball tarballFile ->-      return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]--    UserTargetRemoteTarball tarballURL ->-      return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]--localPackageError :: FilePath -> String-localPackageError dir =-    "Error reading local package.\nCouldn't find .cabal file in: " ++ dir---- --------------------------------------------------------------- * Fetching and reading package targets--- ----------------------------------------------------------------- | Fetch any remote targets so that they can be read.----fetchPackageTarget :: Verbosity-                   -> RepoContext-                   -> PackageTarget (PackageLocation ())-                   -> IO (PackageTarget ResolvedPkgLoc)-fetchPackageTarget verbosity repoCtxt = traverse $-  fetchPackage verbosity repoCtxt . fmap (const Nothing)----- | Given a package target that has been fetched, read the .cabal file.------ This only affects targets given by location, named targets are unaffected.----readPackageTarget :: Verbosity-                  -> PackageTarget ResolvedPkgLoc-                  -> IO (PackageTarget UnresolvedSourcePackage)-readPackageTarget verbosity = traverse modifyLocation-  where-    modifyLocation location = case location of--      LocalUnpackedPackage dir -> do-        pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>=-                 readGenericPackageDescription verbosity-        return SourcePackage-          { srcpkgPackageId     = packageId pkg-          , srcpkgDescription   = pkg-          , srcpkgSource        = fmap Just location-          , srcpkgDescrOverride = Nothing-          }--      LocalTarballPackage tarballFile ->-        readTarballPackageTarget location tarballFile tarballFile--      RemoteTarballPackage tarballURL tarballFile ->-        readTarballPackageTarget location tarballFile (show tarballURL)--      RepoTarballPackage _repo _pkgid _ ->-        error "TODO: readPackageTarget RepoTarballPackage"-        -- For repo tarballs this info should be obtained from the index.--      RemoteSourceRepoPackage _srcRepo _ ->-        error "TODO: readPackageTarget RemoteSourceRepoPackage"-        -- This can't happen, because it would have errored out already-        -- in fetchPackage, via fetchPackageTarget before it gets to this-        -- function.-        ---        -- When that is corrected, this will also need to be fixed.--    readTarballPackageTarget location tarballFile tarballOriginalLoc = do-      (filename, content) <- extractTarballPackageCabalFile-                               tarballFile tarballOriginalLoc-      case parsePackageDescription' content of-        Nothing  -> die' verbosity $ "Could not parse the cabal file "-                       ++ filename ++ " in " ++ tarballFile-        Just pkg ->-          return SourcePackage-            { srcpkgPackageId     = packageId pkg-            , srcpkgDescription   = pkg-            , srcpkgSource        = fmap Just location-            , srcpkgDescrOverride = Nothing-            }--    extractTarballPackageCabalFile :: FilePath -> String-                                   -> IO (FilePath, BS.ByteString)-    extractTarballPackageCabalFile tarballFile tarballOriginalLoc =-          either (die' verbosity . formatErr) return-        . check-        . accumEntryMap-        . Tar.filterEntries isCabalFile-        . Tar.read-        . GZipUtils.maybeDecompress-      =<< BS.readFile tarballFile-      where-        formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg--        accumEntryMap = Tar.foldlEntries-                          (\m e -> Map.insert (Tar.entryTarPath e) e m)-                          Map.empty--        check (Left e)  = Left (show e)-        check (Right m) = case Map.elems m of-            []     -> Left noCabalFile-            [file] -> case Tar.entryContent file of-              Tar.NormalFile content _ -> Right (Tar.entryPath file, content)-              _                        -> Left noCabalFile-            _files -> Left multipleCabalFiles-          where-            noCabalFile        = "No cabal file found"-            multipleCabalFiles = "Multiple cabal files found"--        isCabalFile e = case splitPath (Tar.entryPath e) of-          [     _dir, file] -> takeExtension file == ".cabal"-          [".", _dir, file] -> takeExtension file == ".cabal"-          _                 -> False--    parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription-    parsePackageDescription' bs =-        parseGenericPackageDescriptionMaybe (BS.toStrict bs)---- --------------------------------------------------------------- * Checking package targets--- --------------------------------------------------------------data PackageTargetProblem-   = PackageNameUnknown   PackageName               UserTarget-   | PackageNameAmbiguous PackageName [PackageName] UserTarget-  deriving Show----- | Users are allowed to give package names case-insensitively, so we must--- disambiguate named package references.----disambiguatePackageTargets :: Package pkg'-                           => PackageIndex pkg'-                           -> [PackageName]-                           -> [PackageTarget pkg]-                           -> ( [PackageTargetProblem]-                              , [PackageSpecifier pkg] )-disambiguatePackageTargets availablePkgIndex availableExtra targets =-    partitionEithers (map disambiguatePackageTarget targets)-  where-    disambiguatePackageTarget packageTarget = case packageTarget of-      PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)--      PackageTargetNamed pkgname props userTarget-        | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)-                    -> Left (PackageNameUnknown pkgname userTarget)-        | otherwise -> Right (NamedPackage pkgname props)--      PackageTargetNamedFuzzy pkgname props userTarget ->-        case disambiguatePackageName packageNameEnv pkgname of-          None                 -> Left  (PackageNameUnknown-                                          pkgname userTarget)-          Ambiguous   pkgnames -> Left  (PackageNameAmbiguous-                                          pkgname pkgnames userTarget)-          Unambiguous pkgname' -> Right (NamedPackage pkgname' props)--    -- use any extra specific available packages to help us disambiguate-    packageNameEnv :: PackageNameEnv-    packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)-                             (extraPackageNameEnv availableExtra)----- | Report problems to the user. That is, if there are any problems--- then raise an exception.-reportPackageTargetProblems :: Verbosity-                            -> [PackageTargetProblem] -> IO ()-reportPackageTargetProblems verbosity problems = do-    case [ pkg | PackageNameUnknown pkg originalTarget <- problems-               , not (isUserTagetWorld originalTarget) ] of-      []    -> return ()-      pkgs  -> die' verbosity $ unlines-                       [ "There is no package named '" ++ prettyShow name ++ "'. "-                       | name <- pkgs ]-                  ++ "You may need to run 'cabal update' to get the latest "-                  ++ "list of available packages."--    case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of-      []          -> return ()-      ambiguities -> die' verbosity $ unlines-                         [    "There is no package named '" ++ prettyShow name ++ "'. "-                           ++ (if length matches > 1-                               then "However, the following package names exist: "-                               else "However, the following package name exists: ")-                           ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches]-                           ++ "."-                         | (name, matches) <- ambiguities ]--    case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of-      []   -> return ()-      pkgs -> warn verbosity $-                 "The following 'world' packages will be ignored because "-              ++ "they refer to packages that cannot be found: "-              ++ intercalate ", " (map prettyShow pkgs) ++ "\n"-              ++ "You can suppress this warning by correcting the world file."-  where-    isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False----- --------------------------------------------------------------- * Disambiguating package names--- --------------------------------------------------------------data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]---- | Given a package name and a list of matching names, figure out--- which one it might be referring to. If there is an exact--- case-sensitive match then that's ok (i.e. returned via--- 'Unambiguous'). If it matches just one package case-insensitively--- or if it matches multiple packages case-insensitively, in that case--- the result is 'Ambiguous'.------ Note: Before cabal 2.2, when only a single package matched---       case-insensitively it would be considered 'Unambigious'.----disambiguatePackageName :: PackageNameEnv-                        -> PackageName-                        -> MaybeAmbiguous PackageName-disambiguatePackageName (PackageNameEnv pkgNameLookup) name =-    case nub (pkgNameLookup name) of-      []      -> None-      names   -> case find (name==) names of-                   Just name' -> Unambiguous name'-                   Nothing    -> Ambiguous names---newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])--instance Monoid PackageNameEnv where-  mempty = PackageNameEnv (const [])-  mappend = (<>)--instance Semigroup PackageNameEnv where-  PackageNameEnv lookupA <> PackageNameEnv lookupB =-    PackageNameEnv (\name -> lookupA name ++ lookupB name)--indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv-indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup-  where-    pkgNameLookup pname =-      map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname)--extraPackageNameEnv :: [PackageName] -> PackageNameEnv-extraPackageNameEnv names = PackageNameEnv pkgNameLookup-  where-    pkgNameLookup pname =-      [ pname'-      | let lname = lowercase (unPackageName pname)-      , pname' <- names-      , lowercase (unPackageName pname') == lname ]----- --------------------------------------------------------------- * Package constraints--- ---------------------------------------------------------------- | Version of 'Qualifier' that a user may specify on the--- command line.-data UserQualifier =-  -- | Top-level dependency.-  UserQualToplevel--  -- | Setup dependency.-  | UserQualSetup PackageName--  -- | Executable dependency.-  | UserQualExe PackageName PackageName-  deriving (Eq, Show, Generic)--instance Binary UserQualifier-instance Structured UserQualifier---- | Version of 'ConstraintScope' that a user may specify on the--- command line.-data UserConstraintScope =-  -- | Scope that applies to the package when it has the specified qualifier.-  UserQualified UserQualifier PackageName--  -- | Scope that applies to the package when it has a setup qualifier.-  | UserAnySetupQualifier PackageName--  -- | Scope that applies to the package when it has any qualifier.-  | UserAnyQualifier PackageName-  deriving (Eq, Show, Generic)--instance Binary UserConstraintScope-instance Structured UserConstraintScope--fromUserQualifier :: UserQualifier -> Qualifier-fromUserQualifier UserQualToplevel = QualToplevel-fromUserQualifier (UserQualSetup name) = QualSetup name-fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2--fromUserConstraintScope :: UserConstraintScope -> ConstraintScope-fromUserConstraintScope (UserQualified q pn) =-    ScopeQualified (fromUserQualifier q) pn-fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn-fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn---- | Version of 'PackageConstraint' that the user can specify on--- the command line.-data UserConstraint =-    UserConstraint UserConstraintScope PackageProperty-  deriving (Eq, Show, Generic)--instance Binary UserConstraint-instance Structured UserConstraint--userConstraintPackageName :: UserConstraint -> PackageName-userConstraintPackageName (UserConstraint scope _) = scopePN scope-  where-    scopePN (UserQualified _ pn) = pn-    scopePN (UserAnyQualifier pn) = pn-    scopePN (UserAnySetupQualifier pn) = pn--userToPackageConstraint :: UserConstraint -> PackageConstraint-userToPackageConstraint (UserConstraint scope prop) =-  PackageConstraint (fromUserConstraintScope scope) prop--readUserConstraint :: String -> Either String UserConstraint-readUserConstraint str =-    case explicitEitherParsec parsec str of-      Left err -> Left $ msgCannotParse ++ err-      Right c  -> Right c-  where-    msgCannotParse =-         "expected a (possibly qualified) package name followed by a " ++-         "constraint, which is either a version range, 'installed', " ++-         "'source', 'test', 'bench', or flags. "--instance Pretty UserConstraint where-  pretty (UserConstraint scope prop) =-    dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop--instance Parsec UserConstraint where-    parsec = do-        scope <- parseConstraintScope-        P.spaces-        prop <- P.choice-            [ PackagePropertyFlags                  <$> parsecFlagAssignmentNonEmpty -- headed by "+-"-            , PackagePropertyVersion                <$> parsec                       -- headed by "<=>" (will be)-            , PackagePropertyInstalled              <$ P.string "installed"-            , PackagePropertySource                 <$ P.string "source"-            , PackagePropertyStanzas [TestStanzas]  <$ P.string "test"-            , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"-            ]-        return (UserConstraint scope prop)--      where-        parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope-        parseConstraintScope = do-            pn <- parsec-            P.choice-                [ P.char '.' *> withDot pn-                , P.char ':' *> withColon pn-                , return (UserQualified UserQualToplevel pn)-                ]-          where-            withDot :: PackageName -> m UserConstraintScope-            withDot pn-                | pn == mkPackageName "any"   = UserAnyQualifier <$> parsec-                | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec-                | otherwise                   = P.unexpected $ "constraint scope: " ++ unPackageName pn--            withColon :: PackageName -> m UserConstraintScope-            withColon pn = UserQualified (UserQualSetup pn)-                <$  P.string "setup."-                <*> parsec
− Distribution/Client/Types.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Types--- Copyright   :  (c) David Himmelstrup 2005---                    Duncan Coutts 2011--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Various common data types for the entire cabal-install system-------------------------------------------------------------------------------module Distribution.Client.Types (-    module Distribution.Client.Types.AllowNewer,-    module Distribution.Client.Types.ConfiguredId,-    module Distribution.Client.Types.ConfiguredPackage,-    module Distribution.Client.Types.BuildResults,-    module Distribution.Client.Types.PackageLocation,-    module Distribution.Client.Types.PackageSpecifier,-    module Distribution.Client.Types.ReadyPackage,-    module Distribution.Client.Types.Repo,-    module Distribution.Client.Types.RepoName,-    module Distribution.Client.Types.SourcePackageDb,-    module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy,-) where---import Distribution.Client.Types.AllowNewer-import Distribution.Client.Types.BuildResults-import Distribution.Client.Types.ConfiguredId-import Distribution.Client.Types.ConfiguredPackage-import Distribution.Client.Types.PackageLocation-import Distribution.Client.Types.PackageSpecifier-import Distribution.Client.Types.Repo-import Distribution.Client.Types.RepoName-import Distribution.Client.Types.ReadyPackage-import Distribution.Client.Types.SourcePackageDb-import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
− Distribution/Client/Types/AllowNewer.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.AllowNewer (-    AllowNewer (..),-    AllowOlder (..),-    RelaxDeps (..),-    mkRelaxDepSome,-    RelaxDepMod (..),-    RelaxDepScope (..),-    RelaxDepSubject (..),-    RelaxedDep (..),-    isRelaxDeps,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Parsec            (parsecLeadingCommaNonEmpty)-import Distribution.Types.PackageId   (PackageId, PackageIdentifier (..))-import Distribution.Types.PackageName (PackageName, mkPackageName)-import Distribution.Types.Version     (nullVersion)--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- $setup--- >>> import Distribution.Parsec---- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,--- it may make sense to move these definitions to the Solver.Types--- module---- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)-newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }-                   deriving (Eq, Read, Show, Generic)---- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)-newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }-                   deriving (Eq, Read, Show, Generic)---- | Generic data type for policy when relaxing bounds in dependencies.--- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending--- on whether or not you are relaxing an lower or upper bound--- (respectively).-data RelaxDeps =--  -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.-  ---  -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all-  -- dependencies, never choose versions newer (resp. older) than allowed.-    RelaxDepsSome [RelaxedDep]--  -- | Ignore upper (resp. lower) bounds in dependencies on all packages.-  ---  -- __Note__: This is should be semantically equivalent to-  ---  -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]-  ---  -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')-  | RelaxDepsAll-  deriving (Eq, Read, Show, Generic)---- | Dependencies can be relaxed either for all packages in the install plan, or--- only for some packages.-data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject-                deriving (Eq, Read, Show, Generic)---- | Specify the scope of a relaxation, i.e. limit which depending--- packages are allowed to have their version constraints relaxed.-data RelaxDepScope = RelaxDepScopeAll-                     -- ^ Apply relaxation in any package-                   | RelaxDepScopePackage !PackageName-                     -- ^ Apply relaxation to in all versions of a package-                   | RelaxDepScopePackageId !PackageId-                     -- ^ Apply relaxation to a specific version of a package only-                   deriving (Eq, Read, Show, Generic)---- | Modifier for dependency relaxation-data RelaxDepMod = RelaxDepModNone  -- ^ Default semantics-                 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints-                 deriving (Eq, Read, Show, Generic)---- | Express whether to relax bounds /on/ @all@ packages, or a single package-data RelaxDepSubject = RelaxDepSubjectAll-                     | RelaxDepSubjectPkg !PackageName-                     deriving (Eq, Ord, Read, Show, Generic)--instance Pretty RelaxedDep where-  pretty (RelaxedDep scope rdmod subj) = case scope of-      RelaxDepScopeAll          -> Disp.text "*:"               Disp.<> modDep-      RelaxDepScopePackage   p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep-      RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep-    where-      modDep = case rdmod of-               RelaxDepModNone  -> pretty subj-               RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj--instance Parsec RelaxedDep where-    parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)---- continuation after *-relaxedDepStarP :: CabalParsing m => m RelaxedDep-relaxedDepStarP =-    RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec-    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)---- continuation after package identifier-relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep-relaxedDepPkgidP pid@(PackageIdentifier pn v)-    | pn == mkPackageName "all"-    , v == nullVersion-    =  RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec-    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)--    | v == nullVersion-    = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec-    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))--    | otherwise-    = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec--modP :: P.CharParsing m => m RelaxDepMod-modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone--instance Pretty RelaxDepSubject where-  pretty RelaxDepSubjectAll      = Disp.text "*"-  pretty (RelaxDepSubjectPkg pn) = pretty pn--instance Parsec RelaxDepSubject where-  parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn-    where-      pkgn = do-          pn <- parsec-          pure $ if pn == mkPackageName "all"-              then RelaxDepSubjectAll-              else RelaxDepSubjectPkg pn--instance Pretty RelaxDeps where-  pretty rd | not (isRelaxDeps rd) = Disp.text "none"-  pretty (RelaxDepsSome pkgs)      = Disp.fsep .-                                   Disp.punctuate Disp.comma .-                                   map pretty $ pkgs-  pretty RelaxDepsAll              = Disp.text "all"---- |------ >>> simpleParsec "all" :: Maybe RelaxDeps--- Just RelaxDepsAll------ >>> simpleParsec "none" :: Maybe RelaxDeps--- Just (RelaxDepsSome [])------ >>> simpleParsec "*, *" :: Maybe RelaxDeps--- Just RelaxDepsAll------ >>> simpleParsec "*:*" :: Maybe RelaxDeps--- Just RelaxDepsAll------ >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps--- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])------ This is not a glitch, even it looks like:------ >>> simpleParsec ", all" :: Maybe RelaxDeps--- Just RelaxDepsAll------ >>> simpleParsec "" :: Maybe RelaxDeps--- Nothing----instance Parsec RelaxDeps where-    parsec = do-        xs <- parsecLeadingCommaNonEmpty parsec-        pure $ case toList xs of-            [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]-                -> RelaxDepsAll-            [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]-                | pn == mkPackageName "none"-                -> mempty-            xs' -> mkRelaxDepSome xs'--instance Binary RelaxDeps-instance Binary RelaxDepMod-instance Binary RelaxDepScope-instance Binary RelaxDepSubject-instance Binary RelaxedDep-instance Binary AllowNewer-instance Binary AllowOlder--instance Structured RelaxDeps-instance Structured RelaxDepMod-instance Structured RelaxDepScope-instance Structured RelaxDepSubject-instance Structured RelaxedDep-instance Structured AllowNewer-instance Structured AllowOlder---- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations------ Equivalent to @isRelaxDeps = (/= 'mempty')@-isRelaxDeps :: RelaxDeps -> Bool-isRelaxDeps (RelaxDepsSome [])    = False-isRelaxDeps (RelaxDepsSome (_:_)) = True-isRelaxDeps RelaxDepsAll          = True---- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.-mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps-mkRelaxDepSome xs-    | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs-    = RelaxDepsAll--    | otherwise-    = RelaxDepsSome xs---- | 'RelaxDepsAll' is the /absorbing element/-instance Semigroup RelaxDeps where-    -- identity element-    RelaxDepsSome []    <> r                   = r-    l@(RelaxDepsSome _) <> RelaxDepsSome []    = l-    -- absorbing element-    l@RelaxDepsAll      <> _                   = l-    (RelaxDepsSome   _) <> r@RelaxDepsAll      = r-    -- combining non-{identity,absorbing} elements-    (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)---- | @'RelaxDepsSome' []@ is the /identity element/-instance Monoid RelaxDeps where-  mempty  = RelaxDepsSome []-  mappend = (<>)--instance Semigroup AllowNewer where-  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)--instance Semigroup AllowOlder where-  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)--instance Monoid AllowNewer where-  mempty  = AllowNewer mempty-  mappend = (<>)--instance Monoid AllowOlder where-  mempty  = AllowOlder mempty-  mappend = (<>)
− Distribution/Client/Types/BuildResults.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.BuildResults (-    BuildOutcome,-    BuildOutcomes,-    BuildFailure (..),-    BuildResult (..),-    TestsResult (..),-    DocsResult (..),-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo)-import Distribution.Types.PackageId            (PackageId)-import Distribution.Types.UnitId               (UnitId)---- | A summary of the outcome for building a single package.----type BuildOutcome = Either BuildFailure BuildResult---- | A summary of the outcome for building a whole set of packages.----type BuildOutcomes = Map UnitId BuildOutcome--data BuildFailure = PlanningFailed-                  | DependentFailed PackageId-                  | DownloadFailed  SomeException-                  | UnpackFailed    SomeException-                  | ConfigureFailed SomeException-                  | BuildFailed     SomeException-                  | TestsFailed     SomeException-                  | InstallFailed   SomeException-  deriving (Show, Typeable, Generic)--instance Exception BuildFailure---- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only--- the public library's 'InstalledPackageInfo' is stored here, even if--- there were 'InstalledPackageInfo' from internal libraries.  This--- 'InstalledPackageInfo' is not used anyway, so it makes no difference.-data BuildResult = BuildResult DocsResult TestsResult-                               (Maybe InstalledPackageInfo)-  deriving (Show, Generic)--data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-  deriving (Show, Generic, Typeable)-data TestsResult = TestsNotTried | TestsOk-  deriving (Show, Generic, Typeable)--instance Binary BuildFailure-instance Binary BuildResult-instance Binary DocsResult-instance Binary TestsResult--instance Structured BuildFailure-instance Structured BuildResult-instance Structured DocsResult-instance Structured TestsResult
− Distribution/Client/Types/ConfiguredId.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.ConfiguredId (-    InstalledPackageId,-    ConfiguredId (..),-    annotatedIdToConfiguredId,-    HasConfiguredId (..),-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId)-import Distribution.Package              (Package (..))-import Distribution.Types.AnnotatedId    (AnnotatedId (..))-import Distribution.Types.ComponentId    (ComponentId)-import Distribution.Types.ComponentName  (ComponentName)-import Distribution.Types.PackageId      (PackageId)------------------------------------------------------------------------------------ InstalledPackageId------------------------------------------------------------------------------------ | Within Cabal the library we no longer have a @InstalledPackageId@ type.--- That's because it deals with the compilers' notion of a registered library,--- and those really are libraries not packages. Those are now named units.------ The package management layer does however deal with installed packages, as--- whole packages not just as libraries. So we do still need a type for--- installed package ids. At the moment however we track instaled packages via--- their primary library, which is a unit id. In future this may change--- slightly and we may distinguish these two types and have an explicit--- conversion when we register units with the compiler.----type InstalledPackageId = ComponentId------------------------------------------------------------------------------------ ConfiguredId------------------------------------------------------------------------------------ | A ConfiguredId is a package ID for a configured package.------ Once we configure a source package we know its UnitId. It is still--- however useful in lots of places to also know the source ID for the package.--- We therefore bundle the two.------ An already installed package of course is also "configured" (all its--- configuration parameters and dependencies have been specified).-data ConfiguredId = ConfiguredId {-    confSrcId  :: PackageId-  , confCompName :: Maybe ComponentName-  , confInstId :: ComponentId-  }-  deriving (Eq, Ord, Generic)--annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId-annotatedIdToConfiguredId aid = ConfiguredId {-        confSrcId    = ann_pid aid,-        confCompName = Just (ann_cname aid),-        confInstId   = ann_id aid-    }--instance Binary ConfiguredId-instance Structured ConfiguredId--instance Show ConfiguredId where-  show cid = show (confInstId cid)--instance Package ConfiguredId where-  packageId = confSrcId------------------------------------------------------------------------------------ HasConfiguredId class----------------------------------------------------------------------------------class HasConfiguredId a where-    configuredId :: a -> ConfiguredId---- NB: This instance is slightly dangerous, in that you'll lose--- information about the specific UnitId you depended on.-instance HasConfiguredId InstalledPackageInfo where-    configuredId ipkg = ConfiguredId (packageId ipkg)-                            (Just (sourceComponentName ipkg))-                            (installedComponentId ipkg)
− Distribution/Client/Types/ConfiguredPackage.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies  #-}-module Distribution.Client.Types.ConfiguredPackage (-    ConfiguredPackage (..),-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Compat.Graph (IsNode (..))-import Distribution.Package      (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId)-import Distribution.Types.Flag   (FlagAssignment)-import Distribution.Types.ComponentName-import Distribution.Types.LibraryName (LibraryName (..))-import Distribution.Types.MungedPackageId (computeCompatPackageId)-import Distribution.Simple.Utils (ordNub)--import Distribution.Client.Types.ConfiguredId-import Distribution.Solver.Types.OptionalStanza   (OptionalStanza)-import Distribution.Solver.Types.PackageFixedDeps-import Distribution.Solver.Types.SourcePackage    (SourcePackage)--import qualified Distribution.Solver.Types.ComponentDeps as CD---- | A 'ConfiguredPackage' is a not-yet-installed package along with the--- total configuration information. The configuration information is total in--- the sense that it provides all the configuration information and so the--- final configure process will be independent of the environment.------ 'ConfiguredPackage' is assumed to not support Backpack.  Only the--- @v2-build@ codepath supports Backpack.----data ConfiguredPackage loc = ConfiguredPackage-    { confPkgId      :: InstalledPackageId-    , confPkgSource  :: SourcePackage loc  -- ^ package info, including repo-    , confPkgFlags   :: FlagAssignment     -- ^ complete flag assignment for the package-    , confPkgStanzas :: [OptionalStanza]   -- ^ list of enabled optional stanzas for the package-    , confPkgDeps    :: CD.ComponentDeps [ConfiguredId]-      -- ^ set of exact dependencies (installed or source).-      ---      -- These must be consistent with the 'buildDepends'-      -- in the 'PackageDescription' that you'd get by-      -- applying the flag assignment and optional stanzas.-    }-  deriving (Eq, Show, Generic)---- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.--- This type class is mostly used to conveniently finesse between--- 'ElaboratedPackage' and 'ElaboratedComponent'.----instance HasConfiguredId (ConfiguredPackage loc) where-    configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg)---- 'ConfiguredPackage' is the legacy codepath, we are guaranteed--- to never have a nontrivial 'UnitId'-instance PackageFixedDeps (ConfiguredPackage loc) where-    depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps--instance IsNode (ConfiguredPackage loc) where-    type Key (ConfiguredPackage loc) = UnitId-    nodeKey       = newSimpleUnitId . confPkgId-    -- TODO: if we update ConfiguredPackage to support order-only-    -- dependencies, need to include those here.-    -- NB: have to deduplicate, otherwise the planner gets confused-    nodeNeighbors = ordNub . CD.flatDeps . depends--instance (Binary loc) => Binary (ConfiguredPackage loc)-----instance Package (ConfiguredPackage loc) where-  packageId cpkg = packageId (confPkgSource cpkg)--instance HasMungedPackageId (ConfiguredPackage loc) where-  mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName---- Never has nontrivial UnitId-instance HasUnitId (ConfiguredPackage loc) where-  installedUnitId = newSimpleUnitId . confPkgId--instance PackageInstalled (ConfiguredPackage loc) where-  installedDepends = CD.flatDeps . depends---
− Distribution/Client/Types/Credentials.hs 
@@ -1,9 +0,0 @@-module Distribution.Client.Types.Credentials (-    Username (..),-    Password (..),-) where--import Prelude (String)--newtype Username = Username { unUsername :: String }-newtype Password = Password { unPassword :: String }
− Distribution/Client/Types/InstallMethod.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.InstallMethod where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as PP--data InstallMethod-    = InstallMethodCopy-    | InstallMethodSymlink-  deriving (Eq, Show, Generic, Bounded, Enum)--instance Binary InstallMethod-instance Structured InstallMethod---- | Last-instance Semigroup InstallMethod where-    _ <> x = x--instance Parsec InstallMethod where-    parsec = do-        name <- P.munch1 isAlpha-        case name of-            "copy"    -> pure InstallMethodCopy-            "symlink" -> pure InstallMethodSymlink-            _         -> P.unexpected $ "InstallMethod: " ++ name--instance Pretty InstallMethod where-    pretty InstallMethodCopy    = PP.text "copy"-    pretty InstallMethodSymlink = PP.text "symlink"
− Distribution/Client/Types/OverwritePolicy.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.OverwritePolicy where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as PP--data OverwritePolicy-    = NeverOverwrite-    | AlwaysOverwrite-  deriving (Show, Eq, Generic, Bounded, Enum)--instance Binary OverwritePolicy-instance Structured OverwritePolicy--instance Parsec OverwritePolicy where-    parsec = do-        name <- P.munch1 isAlpha-        case name of-            "always" -> pure AlwaysOverwrite-            "never"  -> pure NeverOverwrite-            _        -> P.unexpected $ "OverwritePolicy: " ++ name--instance Pretty OverwritePolicy where-    pretty NeverOverwrite  = PP.text "never"-    pretty AlwaysOverwrite = PP.text "always"
− Distribution/Client/Types/PackageLocation.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.PackageLocation (-    PackageLocation (..),-    UnresolvedPkgLoc,-    ResolvedPkgLoc,-    UnresolvedSourcePackage,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Network.URI (URI)--import Distribution.Types.PackageId (PackageId)--import Distribution.Client.Types.Repo-import Distribution.Client.Types.SourceRepo    (SourceRepoMaybe)-import Distribution.Solver.Types.SourcePackage (SourcePackage)--type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)--type ResolvedPkgLoc = PackageLocation FilePath--data PackageLocation local =--    -- | An unpacked package in the given dir, or current dir-    LocalUnpackedPackage FilePath--    -- | A package as a tarball that's available as a local tarball-  | LocalTarballPackage FilePath--    -- | A package as a tarball from a remote URI-  | RemoteTarballPackage URI local--    -- | A package available as a tarball from a repository.-    ---    -- It may be from a local repository or from a remote repository, with a-    -- locally cached copy. ie a package available from hackage-  | RepoTarballPackage Repo PackageId local--    -- | A package available from a version control system source repository-  | RemoteSourceRepoPackage SourceRepoMaybe local-  deriving (Show, Functor, Eq, Ord, Generic, Typeable)--instance Binary local => Binary (PackageLocation local)-instance Structured local => Structured (PackageLocation local)---- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'.-type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc
− Distribution/Client/Types/PackageSpecifier.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.PackageSpecifier (-    PackageSpecifier (..),-    pkgSpecifierTarget,-    pkgSpecifierConstraints,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Package           (Package (..), packageName, packageVersion)-import Distribution.Types.PackageName (PackageName)-import Distribution.Version           (thisVersion)--import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.PackageConstraint---- | A fully or partially resolved reference to a package.----data PackageSpecifier pkg =--     -- | A partially specified reference to a package (either source or-     -- installed). It is specified by package name and optionally some-     -- required properties. Use a dependency resolver to pick a specific-     -- package satisfying these properties.-     ---     NamedPackage PackageName [PackageProperty]--     -- | A fully specified source package.-     ---   | SpecificSourcePackage pkg-  deriving (Eq, Show, Functor, Generic)--instance Binary pkg => Binary (PackageSpecifier pkg)-instance Structured pkg => Structured (PackageSpecifier pkg)--pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName-pkgSpecifierTarget (NamedPackage name _)       = name-pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg--pkgSpecifierConstraints :: Package pkg-                        => PackageSpecifier pkg -> [LabeledPackageConstraint]-pkgSpecifierConstraints (NamedPackage name props) = map toLpc props-  where-    toLpc prop = LabeledPackageConstraint-                 (PackageConstraint (scopeToplevel name) prop)-                 ConstraintSourceUserTarget-pkgSpecifierConstraints (SpecificSourcePackage pkg)  =-    [LabeledPackageConstraint pc ConstraintSourceUserTarget]-  where-    pc = PackageConstraint-         (ScopeTarget $ packageName pkg)-         (PackagePropertyVersion $ thisVersion (packageVersion pkg))
− Distribution/Client/Types/ReadyPackage.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies  #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Distribution.Client.Types.ReadyPackage (-    GenericReadyPackage (..),-    ReadyPackage,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Compat.Graph (IsNode (..))-import Distribution.Package      (HasMungedPackageId, HasUnitId, Package, PackageInstalled)--import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage)-import Distribution.Client.Types.PackageLocation   (UnresolvedPkgLoc)-import Distribution.Solver.Types.PackageFixedDeps---- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be--- installed already, hence itself ready to be installed.-newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.-  deriving (Eq, Show, Generic, Package, PackageFixedDeps,-            HasMungedPackageId, HasUnitId, PackageInstalled, Binary)---- Can't newtype derive this-instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where-    type Key (GenericReadyPackage srcpkg) = Key srcpkg-    nodeKey (ReadyPackage spkg) = nodeKey spkg-    nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg--type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
− Distribution/Client/Types/Repo.hs 
@@ -1,190 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.Repo (-    -- * Remote repository-    RemoteRepo (..),-    emptyRemoteRepo,-    -- * Local repository (no-index)-    LocalRepo (..),-    emptyLocalRepo,-    localRepoCacheKey,-    -- * Repository-    Repo (..),-    repoName,-    isRepoRemote,-    maybeRepoRemote,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString)--import Distribution.Simple.Utils (toUTF8BS)--import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)--import qualified Data.ByteString.Lazy.Char8      as LBS-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp--import Distribution.Client.Types.RepoName------------------------------------------------------------------------------------ Remote repository----------------------------------------------------------------------------------data RemoteRepo =-    RemoteRepo {-      remoteRepoName     :: RepoName,-      remoteRepoURI      :: URI,--      -- | Enable secure access?-      ---      -- 'Nothing' here represents "whatever the default is"; this is important-      -- to allow for a smooth transition from opt-in to opt-out security-      -- (once we switch to opt-out, all access to the central Hackage-      -- repository should be secure by default)-      remoteRepoSecure :: Maybe Bool,--      -- | Root key IDs (for bootstrapping)-      remoteRepoRootKeys :: [String],--      -- | Threshold for verification during bootstrapping-      remoteRepoKeyThreshold :: Int,--      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a-      -- special case we may know a repo supports both and want to try HTTPS-      -- if we can, but still allow falling back to HTTP.-      ---      -- This field is not currently stored in the config file, but is filled-      -- in automagically for known repos.-      remoteRepoShouldTryHttps :: Bool-    }--  deriving (Show, Eq, Ord, Generic)--instance Binary RemoteRepo-instance Structured RemoteRepo--instance Pretty RemoteRepo where-    pretty r =-        pretty (remoteRepoName r) <<>> Disp.colon <<>>-        Disp.text (uriToString id (remoteRepoURI r) [])---- | Note: serialised format represends 'RemoteRepo' only partially.-instance Parsec RemoteRepo where-    parsec = do-        name <- parsec-        _ <- P.char ':'-        uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))-        uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)-        return RemoteRepo-            { remoteRepoName           = name-            , remoteRepoURI            = uri-            , remoteRepoSecure         = Nothing-            , remoteRepoRootKeys       = []-            , remoteRepoKeyThreshold   = 0-            , remoteRepoShouldTryHttps = False-            }---- | Construct a partial 'RemoteRepo' value to fold the field parser list over.-emptyRemoteRepo :: RepoName -> RemoteRepo-emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False------------------------------------------------------------------------------------ Local repository------------------------------------------------------------------------------------ | /no-index/ style local repositories.------ https://github.com/haskell/cabal/issues/6359-data LocalRepo = LocalRepo-    { localRepoName        :: RepoName-    , localRepoPath        :: FilePath-    , localRepoSharedCache :: Bool-    }-  deriving (Show, Eq, Ord, Generic)--instance Binary LocalRepo-instance Structured LocalRepo---- | Note: doesn't parse 'localRepoSharedCache' field.-instance Parsec LocalRepo where-    parsec = do-        n <- parsec-        _ <- P.char ':'-        p <- P.munch1 (const True) -- restrict what can be a path?-        return (LocalRepo n p False)--instance Pretty LocalRepo where-    pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p---- | Construct a partial 'LocalRepo' value to fold the field parser list over.-emptyLocalRepo :: RepoName -> LocalRepo-emptyLocalRepo name = LocalRepo name "" False---- | Calculate a cache key for local-repo.------ For remote repositories we just use name, but local repositories may--- all be named "local", so we add a bit of `localRepoPath` into the--- mix.-localRepoCacheKey :: LocalRepo -> String-localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where-    hashPart-        = showHashValue $ truncateHash 8 $ hashValue-        $ LBS.fromStrict $ toUTF8BS $ localRepoPath local------------------------------------------------------------------------------------ Any repository------------------------------------------------------------------------------------ | Different kinds of repositories------ NOTE: It is important that this type remains serializable.-data Repo-    -- | Local repository, without index.-    ---    -- https://github.com/haskell/cabal/issues/6359-  = RepoLocalNoIndex-      { repoLocal    :: LocalRepo-      , repoLocalDir :: FilePath-      }--    -- | Standard (unsecured) remote repositores-  | RepoRemote {-        repoRemote   :: RemoteRepo-      , repoLocalDir :: FilePath-      }--    -- | Secure repositories-    ---    -- Although this contains the same fields as 'RepoRemote', we use a separate-    -- constructor to avoid confusing the two.-    ---    -- Not all access to a secure repo goes through the hackage-security-    -- library currently; code paths that do not still make use of the-    -- 'repoRemote' and 'repoLocalDir' fields directly.-  | RepoSecure {-        repoRemote   :: RemoteRepo-      , repoLocalDir :: FilePath-      }-  deriving (Show, Eq, Ord, Generic)--instance Binary Repo-instance Structured Repo---- | Check if this is a remote repo-isRepoRemote :: Repo -> Bool-isRepoRemote RepoLocalNoIndex{} = False-isRepoRemote _                  = True---- | Extract @RemoteRepo@ from @Repo@ if remote.-maybeRepoRemote :: Repo -> Maybe RemoteRepo-maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing-maybeRepoRemote (RepoRemote       r _localDir) = Just r-maybeRepoRemote (RepoSecure       r _localDir) = Just r--repoName :: Repo -> RepoName-repoName (RepoLocalNoIndex r _) = localRepoName r-repoName (RepoRemote r _)       = remoteRepoName r-repoName (RepoSecure r _)       = remoteRepoName r
− Distribution/Client/Types/RepoName.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.RepoName (-    RepoName (..),-    unRepoName,-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint                as Disp---- $setup--- >>> import Distribution.Parsec---- | Repository name.------ May be used as path segment.----newtype RepoName = RepoName String-  deriving (Show, Eq, Ord, Generic)--unRepoName :: RepoName -> String-unRepoName (RepoName n) = n--instance Binary RepoName-instance Structured RepoName-instance NFData RepoName--instance Pretty RepoName where-    pretty = Disp.text . unRepoName---- |------ >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName--- Just (RepoName "hackage.haskell.org")------ >>> simpleParsec "0123" :: Maybe RepoName--- Nothing----instance Parsec RepoName where-    parsec = RepoName <$> parser where-        parser = (:) <$> lead <*> rest-        lead = P.satisfy (\c -> isAlpha    c || c == '_' || c == '-' || c == '.')-        rest = P.munch   (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
− Distribution/Client/Types/SourcePackageDb.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.SourcePackageDb (-    SourcePackageDb (..),-) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Types.PackageName  (PackageName)-import Distribution.Types.VersionRange (VersionRange)--import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage)-import Distribution.Solver.Types.PackageIndex    (PackageIndex)---- | This is the information we get from a @00-index.tar.gz@ hackage index.----data SourcePackageDb = SourcePackageDb-    { packageIndex       :: PackageIndex UnresolvedSourcePackage-    , packagePreferences :: Map PackageName VersionRange-    }-  deriving (Eq, Generic)--instance Binary SourcePackageDb
− Distribution/Client/Types/SourceRepo.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE DeriveAnyClass       #-}-{-# LANGUAGE DeriveGeneric        #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE StandaloneDeriving   #-}-{-# LANGUAGE UndecidableInstances #-}-module Distribution.Client.Types.SourceRepo (-    SourceRepositoryPackage (..),-    SourceRepoList,-    SourceRepoMaybe,-    SourceRepoProxy,-    srpHoist,-    srpToProxy,-    srpFanOut,-    sourceRepositoryPackageGrammar,-) where--import Distribution.Client.Compat.Prelude-import Distribution.Compat.Lens           (Lens, Lens')-import Prelude ()--import Distribution.FieldGrammar-import Distribution.Types.SourceRepo (RepoType (..))---- | @source-repository-package@ definition----data SourceRepositoryPackage f = SourceRepositoryPackage-    { srpType     :: !RepoType-    , srpLocation :: !String-    , srpTag      :: !(Maybe String)-    , srpBranch   :: !(Maybe String)-    , srpSubdir   :: !(f FilePath)-    }-  deriving (Generic)--deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)-deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)-deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)-deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)-deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)---- | Read from @cabal.project@-type SourceRepoList  = SourceRepositoryPackage []---- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'-type SourceRepoMaybe = SourceRepositoryPackage Maybe---- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.-type SourceRepoProxy = SourceRepositoryPackage Proxy--srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g-srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }--srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy-srpToProxy s = s { srpSubdir = Proxy }---- | Split single @source-repository-package@ declaration with multiple subdirs,--- into multiple ones with at most single subdir.-srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)-srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =-    s { srpSubdir = Nothing } :| []-srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where-    f subdir = s { srpSubdir = Just subdir }------------------------------------------------------------------------------------ Lens----------------------------------------------------------------------------------srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType-srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))-{-# INLINE srpTypeLens #-}--srpLocationLens :: Lens' (SourceRepositoryPackage f) String-srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))-{-# INLINE srpLocationLens #-}--srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)-srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))-{-# INLINE srpTagLens #-}--srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)-srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))-{-# INLINE srpBranchLens #-}--srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)-srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))-{-# INLINE srpSubdirLens #-}------------------------------------------------------------------------------------ Parser & PPrinter----------------------------------------------------------------------------------sourceRepositoryPackageGrammar-    :: ( FieldGrammar c g, Applicative (g SourceRepoList)-       , c (Identity RepoType)-       , c (List NoCommaFSep FilePathNT String)-       )-    => g SourceRepoList SourceRepoList-sourceRepositoryPackageGrammar = SourceRepositoryPackage-    <$> uniqueField      "type"                                       srpTypeLens-    <*> uniqueFieldAla   "location" Token                             srpLocationLens-    <*> optionalFieldAla "tag"      Token                             srpTagLens-    <*> optionalFieldAla "branch"   Token                             srpBranchLens-    <*> monoidalFieldAla "subdir"   (alaList' NoCommaFSep FilePathNT) srpSubdirLens  -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...-{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}-{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}
− Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (-    WriteGhcEnvironmentFilesPolicy (..),-) where--import Prelude ()-import Distribution.Client.Compat.Prelude---- | Whether 'v2-build' should write a .ghc.environment file after--- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+'--- (8.4.4 is the earliest version that supports--- '-package-env -').-data WriteGhcEnvironmentFilesPolicy-  = AlwaysWriteGhcEnvironmentFiles-  | NeverWriteGhcEnvironmentFiles-  | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer-  deriving (Eq, Enum, Bounded, Generic, Show)--instance Binary WriteGhcEnvironmentFilesPolicy-instance Structured WriteGhcEnvironmentFilesPolicy
− Distribution/Client/Update.hs 
@@ -1,117 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Update--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------{-# LANGUAGE RecordWildCards #-}-module Distribution.Client.Update-    ( update-    ) where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Simple.Setup-         ( fromFlag )-import Distribution.Client.Compat.Directory-         ( setModificationTime )-import Distribution.Client.Types-         ( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName )-import Distribution.Client.HttpUtils-         ( DownloadResult(..) )-import Distribution.Client.FetchUtils-         ( downloadIndex )-import Distribution.Client.IndexUtils.Timestamp-import Distribution.Client.IndexUtils.IndexState-import Distribution.Client.IndexUtils-         ( updateRepoIndexCache, Index(..), writeIndexTimestamp-         , currentIndexTimestamp, indexBaseName )-import Distribution.Client.JobControl-         ( newParallelJobControl, spawnJob, collectJob )-import Distribution.Client.Setup-         ( RepoContext(..), UpdateFlags(..) )-import Distribution.Verbosity (lessVerbose)--import Distribution.Simple.Utils-         ( writeFileAtomic, warn, notice, noticeNoWrap )--import qualified Data.ByteString.Lazy       as BS-import Distribution.Client.GZipUtils (maybeDecompress)-import System.FilePath ((<.>), dropExtension)-import Data.Time (getCurrentTime)--import qualified Hackage.Security.Client as Sec---- | 'update' downloads the package list from all known servers-update :: Verbosity -> UpdateFlags -> RepoContext -> IO ()-update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do-  warn verbosity $ "No remote package servers have been specified. Usually "-                ++ "you would have one specified in the config file."-update verbosity updateFlags repoCtxt = do-  let repos       = repoContextRepos repoCtxt-      remoteRepos = mapMaybe maybeRepoRemote repos-  case remoteRepos of-    [] -> return ()-    [remoteRepo] ->-        notice verbosity $ "Downloading the latest package list from "-                        ++ unRepoName (remoteRepoName remoteRepo)-    _ -> notice verbosity . unlines-            $ "Downloading the latest package lists from: "-            : map (("- " ++) . unRepoName . remoteRepoName) remoteRepos-  jobCtrl <- newParallelJobControl (length repos)-  traverse_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos-  traverse_ (\_ -> collectJob jobCtrl) repos--updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()-updateRepo verbosity updateFlags repoCtxt repo = do-  transport <- repoContextGetTransport repoCtxt-  case repo of-    RepoLocalNoIndex{} -> return ()-    RepoRemote{..} -> do-      downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir-      case downloadResult of-        FileAlreadyInCache ->-          setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime-        FileDownloaded indexPath -> do-          writeFileAtomic (dropExtension indexPath) . maybeDecompress-                                                  =<< BS.readFile indexPath-          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)-    RepoSecure remote _ -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do-      let index = RepoIndex repoCtxt repo-      -- NB: This may be a nullTimestamp if we've never updated before-      current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo--      -- NB: always update the timestamp, even if we didn't actually-      -- download anything-      let rname :: RepoName-          rname = remoteRepoName remote--      let repoIndexState :: RepoIndexState-          repoIndexState = lookupIndexState rname (fromFlag (updateIndexState updateFlags))-      writeIndexTimestamp index repoIndexState--      ce <- if repoContextIgnoreExpiry repoCtxt-              then Just `fmap` getCurrentTime-              else return Nothing-      updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce-      -- Update cabal's internal index as well so that it's not out of sync-      -- (If all access to the cache goes through hackage-security this can go)-      case updated of-        Sec.NoUpdates  ->-          setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime-        Sec.HasUpdates ->-          updateRepoIndexCache verbosity index-      -- TODO: This will print multiple times if there are multiple-      -- repositories: main problem is we don't have a way of updating-      -- a specific repo.  Once we implement that, update this.-      when (current_ts /= nullTimestamp) $-        noticeNoWrap verbosity $-          "To revert to previous state run:\n" ++-          "    cabal update --index-state='" ++ prettyShow current_ts ++ "'\n"
− Distribution/Client/Upload.hs 
@@ -1,225 +0,0 @@-module Distribution.Client.Upload (upload, uploadDoc, report) where--import Distribution.Client.Compat.Prelude-import qualified Prelude as Unsafe (tail, head, read)--import Distribution.Client.Types.Credentials ( Username(..), Password(..) )-import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote)-import Distribution.Client.Types.RepoName (unRepoName)-import Distribution.Client.HttpUtils-         ( HttpTransport(..), remoteRepoTryUpgradeToHttps )-import Distribution.Client.Setup-         ( IsCandidate(..), RepoContext(..) )--import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS)-import Distribution.Client.Config--import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import Distribution.Client.BuildReports.Anonymous (parseBuildReport)-import qualified Distribution.Client.BuildReports.Upload as BuildReport--import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName))-import Network.HTTP (Header(..), HeaderName(..))--import System.IO        (hFlush, stdout)-import System.IO.Echo   (withoutInputEcho)-import System.FilePath  ((</>), takeExtension, takeFileName, dropExtension)-import qualified System.FilePath.Posix as FilePath.Posix ((</>))-import System.Directory--type Auth = Maybe (String, String)---- > stripExtensions ["tar", "gz"] "foo.tar.gz"--- Just "foo"--- > stripExtensions ["tar", "gz"] "foo.gz.tar"--- Nothing-stripExtensions :: [String] -> FilePath -> Maybe String-stripExtensions exts path = foldM f path (reverse exts)- where-  f p e-    | takeExtension p == '.':e = Just (dropExtension p)-    | otherwise = Nothing--upload :: Verbosity -> RepoContext-       -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]-       -> IO ()-upload verbosity repoCtxt mUsername mPassword isCandidate paths = do-    let repos = repoContextRepos repoCtxt-    transport  <- repoContextGetTransport repoCtxt-    targetRepo <--      case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of-        [] -> die' verbosity "Cannot upload. No remote repositories are configured."-        (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))-    let targetRepoURI = remoteRepoURI targetRepo-        domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI-        rootIfEmpty x = if null x then "/" else x-        uploadURI = targetRepoURI {-            uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>-              case isCandidate of-                IsCandidate -> "packages/candidates"-                IsPublished -> "upload"-        }-        packageURI pkgid = targetRepoURI {-            uriPath = rootIfEmpty (uriPath targetRepoURI)-                      FilePath.Posix.</> concat-              [ "package/", pkgid-              , case isCandidate of-                  IsCandidate -> "/candidate"-                  IsPublished -> ""-              ]-        }-    Username username <- maybe (promptUsername domain) return mUsername-    Password password <- maybe (promptPassword domain) return mPassword-    let auth = Just (username,password)-    for_ paths $ \path -> do-      notice verbosity $ "Uploading " ++ path ++ "... "-      case fmap takeFileName (stripExtensions ["tar", "gz"] path) of-        Just pkgid -> handlePackage transport verbosity uploadURI-                                    (packageURI pkgid) auth isCandidate path-        -- This case shouldn't really happen, since we check in Main that we-        -- only pass tar.gz files to upload.-        Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path--uploadDoc :: Verbosity -> RepoContext-          -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath-          -> IO ()-uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do-    let repos = repoContextRepos repoCtxt-    transport  <- repoContextGetTransport repoCtxt-    targetRepo <--      case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of-        [] -> die' verbosity $ "Cannot upload. No remote repositories are configured."-        (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))-    let targetRepoURI = remoteRepoURI targetRepo-        domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI-        rootIfEmpty x = if null x then "/" else x-        uploadURI = targetRepoURI {-            uriPath = rootIfEmpty (uriPath targetRepoURI)-                      FilePath.Posix.</> concat-              [ "package/", pkgid-              , case isCandidate of-                IsCandidate -> "/candidate"-                IsPublished -> ""-              , "/docs"-              ]-        }-        packageUri = targetRepoURI {-            uriPath = rootIfEmpty (uriPath targetRepoURI)-                      FilePath.Posix.</> concat-              [ "package/", pkgid-              , case isCandidate of-                  IsCandidate -> "/candidate"-                  IsPublished -> ""-              ]-        }-        (reverseSuffix, reversePkgid) = break (== '-')-                                        (reverse (takeFileName path))-        pkgid = reverse $ Unsafe.tail reversePkgid-    when (reverse reverseSuffix /= "docs.tar.gz"-          || null reversePkgid || Unsafe.head reversePkgid /= '-') $-      die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"-    Username username <- maybe (promptUsername domain) return mUsername-    Password password <- maybe (promptPassword domain) return mPassword--    let auth = Just (username,password)-        headers =-          [ Header HdrContentType "application/x-tar"-          , Header HdrContentEncoding "gzip"-          ]-    notice verbosity $ "Uploading documentation " ++ path ++ "... "-    resp <- putHttpFile transport verbosity uploadURI path auth headers-    case resp of-      -- Hackage responds with 204 No Content when docs are uploaded-      -- successfully.-      (code,_) | code `elem` [200,204] -> do-        notice verbosity $ okMessage packageUri-      (code,err)  -> do-        notice verbosity $ "Error uploading documentation "-                        ++ path ++ ": "-                        ++ "http code " ++ show code ++ "\n"-                        ++ err-        exitFailure-  where-    okMessage packageUri = case isCandidate of-      IsCandidate ->-        "Documentation successfully uploaded for package candidate. "-        ++ "You can now preview the result at '" ++ show packageUri-        ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'."-      IsPublished ->-        "Package documentation successfully published. You can now view it at '"-        ++ show packageUri ++ "'."---promptUsername :: String -> IO Username-promptUsername domain = do-  putStr $ domain ++ " username: "-  hFlush stdout-  fmap Username getLine--promptPassword :: String -> IO Password-promptPassword domain = do-  putStr $ domain ++ " password: "-  hFlush stdout-  -- save/restore the terminal echoing status (no echoing for entering the password)-  passwd <- withoutInputEcho $ fmap Password getLine-  putStrLn ""-  return passwd--report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO ()-report verbosity repoCtxt mUsername mPassword = do-  let repos       = repoContextRepos repoCtxt-      remoteRepos = mapMaybe maybeRepoRemote repos-  for_ remoteRepos $ \remoteRepo -> do-      let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)-      Username username <- maybe (promptUsername domain) return mUsername-      Password password <- maybe (promptPassword domain) return mPassword-      let auth        = (username, password)--      dotCabal <- getCabalDir-      let srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)-      -- We don't want to bomb out just because we haven't built any packages-      -- from this repo yet.-      srcExists <- doesDirectoryExist srcDir-      when srcExists $ do-        contents <- getDirectoryContents srcDir-        for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->-          do inp <- readFile (srcDir </> logFile)-             let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse-             case parseBuildReport (toUTF8BS reportStr) of-               Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME-               Right report' ->-                 do info verbosity $ "Uploading report for "-                      ++ prettyShow (BuildReport.package report')-                    BuildReport.uploadReports verbosity repoCtxt auth-                      (remoteRepoURI remoteRepo) [(report', Just buildLog)]-                    return ()--handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth-              -> IsCandidate -> FilePath -> IO ()-handlePackage transport verbosity uri packageUri auth isCandidate path =-  do resp <- postHttpFile transport verbosity uri path auth-     case resp of-       (code,warnings) | code `elem` [200, 204] ->-          notice verbosity $ okMessage isCandidate ++-            if null warnings then "" else "\n" ++ formatWarnings (trim warnings)-       (code,err)  -> do-          notice verbosity $ "Error uploading " ++ path ++ ": "-                          ++ "http code " ++ show code ++ "\n"-                          ++ err-          exitFailure- where-  okMessage IsCandidate =-    "Package successfully uploaded as candidate. "-    ++ "You can now preview the result at '" ++ show packageUri-    ++ "'. To publish the candidate, use 'cabal upload --publish'."-  okMessage IsPublished =-    "Package successfully published. You can now view it at '"-    ++ show packageUri ++ "'."--formatWarnings :: String -> String-formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x---- Trim-trim :: String -> String-trim = f . f-      where f = reverse . dropWhile isSpace
− Distribution/Client/Utils.hs 
@@ -1,369 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, CPP #-}--module Distribution.Client.Utils ( MergeResult(..)-                                 , mergeBy, duplicates, duplicatesBy-                                 , readMaybe-                                 , inDir, withEnv, withEnvOverrides-                                 , logDirChange, withExtraPathEnv-                                 , determineNumJobs, numberOfProcessors-                                 , removeExistingFile-                                 , withTempFileName-                                 , makeAbsoluteToCwd-                                 , makeRelativeToCwd, makeRelativeToDir-                                 , makeRelativeCanonical-                                 , filePathToByteString-                                 , byteStringToFilePath, tryCanonicalizePath-                                 , canonicalizePathNoThrow-                                 , moreRecentFile, existsAndIsMoreRecentThan-                                 , tryFindAddSourcePackageDesc-                                 , tryFindPackageDesc-                                 , relaxEncodingErrors-                                 , ProgressPhase (..)-                                 , progressMessage-                                 , cabalInstallVersion)-       where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Compat.Environment-import Distribution.Compat.Time        ( getModTime )-import Distribution.Simple.Setup       ( Flag(..) )-import Distribution.Version-import Distribution.Simple.Utils       ( die', findPackageDesc, noticeNoWrap )-import qualified Data.ByteString.Lazy as BS-import Data.Bits-         ( (.|.), shiftL, shiftR )-import System.FilePath-import Control.Monad-         ( zipWithM_ )-import Data.List-         ( groupBy )-import Foreign.C.Types ( CInt(..) )-import qualified Control.Exception as Exception-         ( finally, bracket )-import System.Directory-         ( canonicalizePath, doesFileExist, getCurrentDirectory-         , removeFile, setCurrentDirectory )-import System.IO-         ( Handle, hClose, openTempFile-         , hGetEncoding, hSetEncoding-         )-import System.IO.Unsafe ( unsafePerformIO )--import GHC.IO.Encoding-         ( recover, TextEncoding(TextEncoding) )-import GHC.IO.Encoding.Failure-         ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )--#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)-import qualified System.Directory as Dir-import qualified System.IO.Error as IOError-#endif--#ifndef __DOCTEST__-import qualified Paths_cabal_install (version)-#endif---- | Generic merging utility. For sorted input lists this is a full outer join.----mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]-mergeBy cmp = merge-  where-    merge []     ys     = [ OnlyInRight y | y <- ys]-    merge xs     []     = [ OnlyInLeft  x | x <- xs]-    merge (x:xs) (y:ys) =-      case x `cmp` y of-        GT -> OnlyInRight   y : merge (x:xs) ys-        EQ -> InBoth      x y : merge xs     ys-        LT -> OnlyInLeft  x   : merge xs  (y:ys)--data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b--duplicates :: Ord a => [a] -> [[a]]-duplicates = duplicatesBy compare--duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]-duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp-  where-    eq a b = case cmp a b of-               EQ -> True-               _  -> False-    moreThanOne (_:_:_) = True-    moreThanOne _       = False---- | Like 'removeFile', but does not throw an exception when the file does not--- exist.-removeExistingFile :: FilePath -> IO ()-removeExistingFile path = do-  exists <- doesFileExist path-  when exists $-    removeFile path---- | A variant of 'withTempFile' that only gives us the file name, and while--- it will clean up the file afterwards, it's lenient if the file is--- moved\/deleted.----withTempFileName :: FilePath-                 -> String-                 -> (FilePath -> IO a) -> IO a-withTempFileName tmpDir template action =-  Exception.bracket-    (openTempFile tmpDir template)-    (\(name, _) -> removeExistingFile name)-    (\(name, h) -> hClose h >> action name)---- | Executes the action in the specified directory.------ Warning: This operation is NOT thread-safe, because current--- working directory is a process-global concept.-inDir :: Maybe FilePath -> IO a -> IO a-inDir Nothing m = m-inDir (Just d) m = do-  old <- getCurrentDirectory-  setCurrentDirectory d-  m `Exception.finally` setCurrentDirectory old---- | Executes the action with an environment variable set to some--- value.------ Warning: This operation is NOT thread-safe, because current--- environment is a process-global concept.-withEnv :: String -> String -> IO a -> IO a-withEnv k v m = do-  mb_old <- lookupEnv k-  setEnv k v-  m `Exception.finally` (case mb_old of-    Nothing -> unsetEnv k-    Just old -> setEnv k old)---- | Executes the action with a list of environment variables and--- corresponding overrides, where------ * @'Just' v@ means \"set the environment variable's value to @v@\".--- * 'Nothing' means \"unset the environment variable\".------ Warning: This operation is NOT thread-safe, because current--- environment is a process-global concept.-withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a-withEnvOverrides overrides m = do-  mb_olds <- traverse lookupEnv envVars-  traverse_ (uncurry update) overrides-  m `Exception.finally` zipWithM_ update envVars mb_olds-   where-    envVars :: [String]-    envVars = map fst overrides--    update :: String -> Maybe FilePath -> IO ()-    update var Nothing    = unsetEnv var-    update var (Just val) = setEnv var val---- | Executes the action, increasing the PATH environment--- in some way------ Warning: This operation is NOT thread-safe, because the--- environment variables are a process-global concept.-withExtraPathEnv :: [FilePath] -> IO a -> IO a-withExtraPathEnv paths m = do-  oldPathSplit <- getSearchPath-  let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)-      oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit-      -- TODO: This is a horrible hack to work around the fact that-      -- setEnv can't take empty values as an argument-      mungePath p | p == ""   = "/dev/null"-                  | otherwise = p-  setEnv "PATH" newPath-  m `Exception.finally` setEnv "PATH" oldPath---- | Log directory change in 'make' compatible syntax-logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a-logDirChange _ Nothing m = m-logDirChange l (Just d) m = do-  l $ "cabal: Entering directory '" ++ d ++ "'\n"-  m `Exception.finally`-    (l $ "cabal: Leaving directory '" ++ d ++ "'\n")--foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt---- The number of processors is not going to change during the duration of the--- program, so unsafePerformIO is safe here.-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-makeAbsoluteToCwd path | isAbsolute path = return path-                       | otherwise       = do cwd <- getCurrentDirectory-                                              return $! cwd </> path---- | Given a path (relative or absolute), make it relative to the current--- directory, including using @../..@ if necessary.-makeRelativeToCwd :: FilePath -> IO FilePath-makeRelativeToCwd path =-    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory---- | Given a path (relative or absolute), make it relative to the given--- directory, including using @../..@ if necessary.-makeRelativeToDir :: FilePath -> FilePath -> IO FilePath-makeRelativeToDir path dir =-    makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir---- | Given a canonical absolute path and canonical absolute dir, make the path--- relative to the directory, including using @../..@ if necessary. Returns--- the original absolute path if it is not on the same drive as the given dir.-makeRelativeCanonical :: FilePath -> FilePath -> FilePath-makeRelativeCanonical path dir-  | takeDrive path /= takeDrive dir = path-  | otherwise                       = go (splitPath path) (splitPath dir)-  where-    go (p:ps) (d:ds) | p == d = go ps ds-    go    []     []           = "./"-    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)---- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is--- encoded as a little-endian 'Word32'.-filePathToByteString :: FilePath -> BS.ByteString-filePathToByteString p =-  BS.pack $ foldr conv [] codepts-  where-    codepts :: [Word32]-    codepts = map (fromIntegral . ord) p--    conv :: Word32 -> [Word8] -> [Word8]-    conv w32 rest = b0:b1:b2:b3:rest-      where-        b0 = fromIntegral $ w32-        b1 = fromIntegral $ w32 `shiftR` 8-        b2 = fromIntegral $ w32 `shiftR` 16-        b3 = fromIntegral $ w32 `shiftR` 24---- | Reverse operation to 'filePathToByteString'.-byteStringToFilePath :: BS.ByteString -> FilePath-byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected-                        | otherwise = go 0-  where-    unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"-    bslen = BS.length bs--    go i | i == bslen = []-         | otherwise = (chr . fromIntegral $ w32) : go (i+4)-      where-        w32 :: Word32-        w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)-        b0 = fromIntegral $ BS.index bs i-        b1 = fromIntegral $ BS.index bs (i + 1)-        b2 = fromIntegral $ BS.index bs (i + 2)-        b3 = fromIntegral $ BS.index bs (i + 3)---- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always--- throws an error if the path refers to a non-existent file.-tryCanonicalizePath :: FilePath -> IO FilePath-tryCanonicalizePath path = do-  ret <- canonicalizePath path-#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)-  exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)-  unless exists $-    IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"-                        Nothing (Just ret)-#endif-  return ret---- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws--- an exception, returns the path argument unmodified.-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---- | Sets the handler for encoding errors to one that transliterates invalid--- characters into one present in the encoding (i.e., \'?\').--- This is opposed to the default behavior, which is to throw an exception on--- error. This function will ignore file handles that have a Unicode encoding--- set. It's a no-op for versions of `base` less than 4.4.-relaxEncodingErrors :: Handle -> IO ()-relaxEncodingErrors handle = do-  maybeEncoding <- hGetEncoding handle-  case maybeEncoding of-    Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->-      let relax x = x { recover = recoverEncode TransliterateCodingFailure }-      in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))-    _ ->-      return ()---- |Like 'tryFindPackageDesc', but with error specific to add-source deps.-tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath-tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $-    err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "-    ++ depPath---- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be--- found, with @err@ prefixing the error message. This function simply allows--- us to give a more descriptive error than that provided by @findPackageDesc@.-tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath-tryFindPackageDesc verbosity depPath err = do-    errOrCabalFile <- findPackageDesc depPath-    case errOrCabalFile of-        Right file -> return file-        Left _ -> die' verbosity err---- | Phase of building a dependency. Represents current status of package--- dependency processing. See #4040 for details.-data ProgressPhase-    = ProgressDownloading-    | ProgressDownloaded-    | ProgressStarting-    | ProgressBuilding-    | ProgressHaddock-    | ProgressInstalling-    | ProgressCompleted--progressMessage :: Verbosity -> ProgressPhase -> String -> IO ()-progressMessage verbosity phase subject = do-    noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n"-  where-    phaseStr = case phase of-        ProgressDownloading -> "Downloading  "-        ProgressDownloaded  -> "Downloaded   "-        ProgressStarting    -> "Starting     "-        ProgressBuilding    -> "Building     "-        ProgressHaddock     -> "Haddock      "-        ProgressInstalling  -> "Installing   "-        ProgressCompleted   -> "Completed    "--cabalInstallVersion :: Version-#ifdef __DOCTEST__-cabalInstallVersion = mkVersion [3,3]-#else-cabalInstallVersion = mkVersion' Paths_cabal_install.version-#endif
− Distribution/Client/Utils/Assertion.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Client.Utils.Assertion (expensiveAssert) where---#ifdef DEBUG_EXPENSIVE_ASSERTIONS-import Prelude (Bool)-import Control.Exception (assert)-import Distribution.Compat.Stack-#else-import Prelude (Bool, id)-#endif---- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This--- function can be used for expensive assertions that should only be turned on--- during testing or debugging.-#ifdef DEBUG_EXPENSIVE_ASSERTIONS-expensiveAssert :: WithCallStack (Bool -> a -> a)-expensiveAssert = assert-#else-expensiveAssert :: Bool -> a -> a-expensiveAssert _ = id-#endif
− Distribution/Client/Utils/Json.hs 
@@ -1,222 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Minimal JSON / RFC 7159 support------ The API is heavily inspired by @aeson@'s API but puts emphasis on--- simplicity rather than performance. The 'ToJSON' instances are--- intended to have an encoding compatible with @aeson@'s encoding.----module Distribution.Client.Utils.Json-    ( Value(..)-    , Object, object, Pair, (.=)-    , encodeToString-    , encodeToBuilder-    , ToJSON(toJSON)-    )-    where--import Distribution.Client.Compat.Prelude--import Data.Char (intToDigit)--import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BB---- TODO: We may want to replace 'String' with 'Text' or 'ByteString'---- | A JSON value represented as a Haskell value.-data Value = Object !Object-           | Array  [Value]-           | String  String-           | Number !Double-           | Bool   !Bool-           | Null-           deriving (Eq, Read, Show)---- | A key\/value pair for an 'Object'-type Pair = (String, Value)---- | A JSON \"object\" (key/value map).-type Object = [Pair]--infixr 8 .=---- | A key-value pair for encoding a JSON object.-(.=) :: ToJSON v => String -> v -> Pair-k .= v  = (k, toJSON v)---- | Create a 'Value' from a list of name\/value 'Pair's.-object :: [Pair] -> Value-object = Object--instance IsString Value where-  fromString = String----- | A type that can be converted to JSON.-class ToJSON a where-  -- | Convert a Haskell value to a JSON-friendly intermediate type.-  toJSON :: a -> Value--instance ToJSON () where-  toJSON () = Array []--instance ToJSON Value where-  toJSON = id--instance ToJSON Bool where-  toJSON = Bool--instance ToJSON a => ToJSON [a] where-  toJSON = Array . map toJSON--instance ToJSON a => ToJSON (Maybe a) where-  toJSON Nothing  = Null-  toJSON (Just a) = toJSON a--instance (ToJSON a,ToJSON b) => ToJSON (a,b) where-  toJSON (a,b) = Array [toJSON a, toJSON b]--instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where-  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]--instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where-  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]--instance ToJSON Float where-  toJSON = Number . realToFrac--instance ToJSON Double where-  toJSON = Number--instance ToJSON Int    where  toJSON = Number . realToFrac-instance ToJSON Int8   where  toJSON = Number . realToFrac-instance ToJSON Int16  where  toJSON = Number . realToFrac-instance ToJSON Int32  where  toJSON = Number . realToFrac--instance ToJSON Word   where  toJSON = Number . realToFrac-instance ToJSON Word8  where  toJSON = Number . realToFrac-instance ToJSON Word16 where  toJSON = Number . realToFrac-instance ToJSON Word32 where  toJSON = Number . realToFrac---- | Possibly lossy due to conversion to 'Double'-instance ToJSON Int64  where  toJSON = Number . realToFrac---- | Possibly lossy due to conversion to 'Double'-instance ToJSON Word64 where  toJSON = Number . realToFrac---- | Possibly lossy due to conversion to 'Double'-instance ToJSON Integer where toJSON = Number . fromInteger----------------------------------------------------------------------------------- 'BB.Builder'-based encoding---- | Serialise value as JSON/UTF8-encoded 'Builder'-encodeToBuilder :: ToJSON a => a -> Builder-encodeToBuilder = encodeValueBB . toJSON--encodeValueBB :: Value -> Builder-encodeValueBB jv = case jv of-  Bool True  -> "true"-  Bool False -> "false"-  Null       -> "null"-  Number n-    | isNaN n || isInfinite n   -> encodeValueBB Null-    | Just i <- doubleToInt64 n -> BB.int64Dec i-    | otherwise                 -> BB.doubleDec n-  Array a  -> encodeArrayBB a-  String s -> encodeStringBB s-  Object o -> encodeObjectBB o--encodeArrayBB :: [Value] -> Builder-encodeArrayBB [] = "[]"-encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'-  where-    go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB--encodeObjectBB :: Object -> Builder-encodeObjectBB [] = "{}"-encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'-  where-    go = mconcat . intersperse (BB.char8 ',') . map encPair-    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x--encodeStringBB :: String -> Builder-encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'-  where-    go = BB.stringUtf8 . escapeString----------------------------------------------------------------------------------- 'String'-based encoding---- | Serialise value as JSON-encoded Unicode 'String'-encodeToString :: ToJSON a => a -> String-encodeToString jv = encodeValue (toJSON jv) []--encodeValue :: Value -> ShowS-encodeValue jv = case jv of-  Bool b   -> showString (if b then "true" else "false")-  Null     -> showString "null"-  Number n-    | isNaN n || isInfinite n    -> encodeValue Null-    | Just i <- doubleToInt64 n -> shows i-    | otherwise                 -> shows n-  Array a -> encodeArray a-  String s -> encodeString s-  Object o -> encodeObject o--encodeArray :: [Value] -> ShowS-encodeArray [] = showString "[]"-encodeArray jvs = ('[':) . go jvs . (']':)-  where-    go []     = id-    go [x]    = encodeValue x-    go (x:xs) = encodeValue x . (',':) . go xs--encodeObject :: Object -> ShowS-encodeObject [] = showString "{}"-encodeObject jvs = ('{':) . go jvs . ('}':)-  where-    go []          = id-    go [(l,x)]     = encodeString l . (':':) . encodeValue x-    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs--encodeString :: String -> ShowS-encodeString str = ('"':) . showString (escapeString str) . ('"':)----------------------------------------------------------------------------------- helpers---- | Try to convert 'Double' into 'Int64', return 'Nothing' if not--- representable loss-free as integral 'Int64' value.-doubleToInt64 :: Double -> Maybe Int64-doubleToInt64 x-  | fromInteger x' == x-  , x' <= toInteger (maxBound :: Int64)-  , x' >= toInteger (minBound :: Int64)-    = Just (fromIntegral x')-  | otherwise = Nothing-  where-    x' = round x---- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"-escapeString :: String -> String-escapeString s-  | not (any needsEscape s) = s-  | otherwise               = escape s-  where-    escape [] = []-    escape (x:xs) = case x of-      '\\' -> '\\':'\\':escape xs-      '"'  -> '\\':'"':escape xs-      '\b' -> '\\':'b':escape xs-      '\f' -> '\\':'f':escape xs-      '\n' -> '\\':'n':escape xs-      '\r' -> '\\':'r':escape xs-      '\t' -> '\\':'t':escape xs-      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs-        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs-        | otherwise    -> c : escape xs--    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF-    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
− Distribution/Client/Utils/Parsec.hs 
@@ -1,102 +0,0 @@-module Distribution.Client.Utils.Parsec (-    renderParseError,-    ) where--import Distribution.Client.Compat.Prelude-import Prelude ()-import System.FilePath                    (normalise)--import qualified Data.ByteString       as BS-import qualified Data.ByteString.Char8 as BS8--import Distribution.Parsec       (PError (..), PWarning (..), Position (..), showPos, zeroPos)-import Distribution.Simple.Utils (fromUTF8BS)---- | Render parse error highlighting the part of the input file.-renderParseError-    :: FilePath-    -> BS.ByteString-    -> NonEmpty PError-    -> [PWarning]-    -> String-renderParseError filepath contents errors warnings = unlines $-    [ "Errors encountered when parsing cabal file " <> filepath <> ":"-    ]-    ++ renderedErrors-    ++ renderedWarnings-  where-    filepath' = normalise filepath--    -- lines of the input file. 'lines' is taken, so they are called rows-    -- contents, line number, whether it's empty line-    rows :: [(String, Int, Bool)]-    rows = zipWith f (BS8.lines contents) [1..] where-        f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s)--    rowsZipper = listToZipper rows--    isEmptyOrComment :: String -> Bool-    isEmptyOrComment s = case dropWhile (== ' ') s of-        ""          -> True   -- empty-        ('-':'-':_) -> True   -- comment-        _           -> False--    renderedErrors   = concatMap renderError errors-    renderedWarnings = concatMap renderWarning warnings--    renderError :: PError -> [String]-    renderError (PError pos@(Position row col) msg)-        -- if position is 0:0, then it doesn't make sense to show input-        -- looks like, Parsec errors have line-feed in them-        | pos == zeroPos = msgs-        | otherwise      = msgs ++ formatInput row col-      where-        msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ]--    renderWarning :: PWarning -> [String]-    renderWarning (PWarning _ pos@(Position row col) msg)-        | pos == zeroPos = msgs-        | otherwise      = msgs ++ formatInput row col-      where-        msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ]--    -- sometimes there are (especially trailing) newlines.-    trimLF :: String -> String-    trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse--    -- format line: prepend the given line number-    formatInput :: Int -> Int -> [String]-    formatInput row col = case advance (row - 1) rowsZipper of-        Zipper xs ys -> before ++ after where-            before = case span (\(_, _, b) -> b) xs of-                (_, [])     -> []-                (zs, z : _) -> map formatInputLine $ z : reverse zs--            after  = case ys of-                []        -> []-                (z : _zs) ->-                    [ formatInputLine z                             -- error line-                    , "      | " ++ replicate (col - 1) ' ' ++ "^"  -- pointer: ^-                    ]-                    -- do we need rows after?-                    -- ++ map formatInputLine (take 1 zs)           -- one row after--    formatInputLine :: (String, Int, Bool) -> String-    formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str--    -- hopefully we don't need to work with over 99999 lines .cabal files-    -- at that point small glitches in error messages are hopefully fine.-    leftPadShow :: Int -> String-    leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s--data Zipper a = Zipper [a] [a]--listToZipper :: [a] -> Zipper a-listToZipper = Zipper []--advance :: Int -> Zipper a -> Zipper a-advance n z@(Zipper xs ys)-    | n <= 0 = z-    | otherwise = case ys of-        []      -> z-        (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys'
− Distribution/Client/VCS.hs 
@@ -1,641 +0,0 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}-module Distribution.Client.VCS (-    -- * VCS driver type-    VCS,-    vcsRepoType,-    vcsProgram,-    -- ** Type re-exports-    RepoType,-    Program,-    ConfiguredProgram,--    -- * Validating 'SourceRepo's and configuring VCS drivers-    validatePDSourceRepo,-    validateSourceRepo,-    validateSourceRepos,-    SourceRepoProblem(..),-    configureVCS,-    configureVCSs,--    -- * Running the VCS driver-    cloneSourceRepo,-    syncSourceRepos,--    -- * The individual VCS drivers-    knownVCSs,-    vcsBzr,-    vcsDarcs,-    vcsGit,-    vcsHg,-    vcsSvn,-    vcsPijul,-  ) where--import Prelude ()-import Distribution.Client.Compat.Prelude--import Distribution.Types.SourceRepo-         ( RepoType(..), KnownRepoType (..) )-import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)-import Distribution.Client.RebuildMonad-         ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )-import Distribution.Verbosity as Verbosity-         ( normal )-import Distribution.Simple.Program-         ( Program(programFindVersion)-         , ConfiguredProgram(programVersion)-         , simpleProgram, findProgramVersion-         , ProgramInvocation(..), programInvocation, runProgramInvocation-         , emptyProgramDb, requireProgram )-import Distribution.Version-         ( mkVersion )-import qualified Distribution.PackageDescription as PD--import Control.Monad.Trans-         ( liftIO )-import qualified Data.Char as Char-import qualified Data.Map  as Map-import System.FilePath-         ( takeDirectory )-import System.Directory-         ( doesDirectoryExist )----- | A driver for a version control system, e.g. git, darcs etc.----data VCS program = VCS {-       -- | The type of repository this driver is for.-       vcsRepoType  :: RepoType,--       -- | The vcs program itself.-       -- This is used at type 'Program' and 'ConfiguredProgram'.-       vcsProgram   :: program,--       -- | The program invocation(s) to get\/clone a repository into a fresh-       -- local directory.-       vcsCloneRepo :: forall f. Verbosity-                    -> ConfiguredProgram-                    -> SourceRepositoryPackage f-                    -> FilePath   -- Source URI-                    -> FilePath   -- Destination directory-                    -> [ProgramInvocation],--       -- | The program invocation(s) to synchronise a whole set of /related/-       -- repositories with corresponding local directories. Also returns the-       -- files that the command depends on, for change monitoring.-       vcsSyncRepos :: forall f. Verbosity-                    -> ConfiguredProgram-                    -> [(SourceRepositoryPackage f, FilePath)]-                    -> IO [MonitorFilePath]-     }----- --------------------------------------------------------------- * Selecting repos and drivers--- --------------------------------------------------------------data SourceRepoProblem = SourceRepoRepoTypeUnspecified-                       | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType-                       | SourceRepoLocationUnspecified-  deriving Show---- | Validates that the 'SourceRepo' specifies a location URI and a repository--- type that is supported by a VCS driver.------ | It also returns the 'VCS' driver we should use to work with it.----validateSourceRepo-    :: SourceRepositoryPackage f-    -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)-validateSourceRepo = \repo -> do-    let rtype = srpType repo-    vcs   <- Map.lookup rtype knownVCSs  ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype-    let uri = srpLocation repo-    return (repo, uri, rtype, vcs)-  where-    a ?! e = maybe (Left e) Right a--validatePDSourceRepo-    :: PD.SourceRepo-    -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)-validatePDSourceRepo repo = do-    rtype <- PD.repoType repo      ?! SourceRepoRepoTypeUnspecified-    uri   <- PD.repoLocation repo  ?! SourceRepoLocationUnspecified-    validateSourceRepo SourceRepositoryPackage-        { srpType     = rtype-        , srpLocation = uri-        , srpTag      = PD.repoTag repo-        , srpBranch   = PD.repoBranch repo-        , srpSubdir   = PD.repoSubdir repo-        }-  where-    a ?! e = maybe (Left e) Right a------ | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return--- things in a convenient form to pass to 'configureVCSs', or to report--- problems.----validateSourceRepos :: [SourceRepositoryPackage f]-                    -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]-                              [(SourceRepositoryPackage f, String, RepoType, VCS Program)]-validateSourceRepos rs =-    case partitionEithers (map validateSourceRepo' rs) of-      (problems@(_:_), _) -> Left problems-      ([], vcss)          -> Right vcss-  where-    validateSourceRepo' r = either (Left . (,) r) Right-                                   (validateSourceRepo r)---configureVCS :: Verbosity-             -> VCS Program-             -> IO (VCS ConfiguredProgram)-configureVCS verbosity vcs@VCS{vcsProgram = prog} =-    asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb-  where-    asVcsConfigured (prog', _) = vcs { vcsProgram = prog' }--configureVCSs :: Verbosity-              -> Map RepoType (VCS Program)-              -> IO (Map RepoType (VCS ConfiguredProgram))-configureVCSs verbosity = traverse (configureVCS verbosity)----- --------------------------------------------------------------- * Running the driver--- ---------------------------------------------------------------- | Clone a single source repo into a fresh directory, using a configured VCS.------ This is for making a new copy, not synchronising an existing copy. It will--- fail if the destination directory already exists.------ Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.-----cloneSourceRepo-    :: Verbosity-    -> VCS ConfiguredProgram-    -> SourceRepositoryPackage f-    -> [Char]-    -> IO ()-cloneSourceRepo verbosity vcs-                repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =-    traverse_ (runProgramInvocation verbosity) invocations-  where-    invocations = vcsCloneRepo vcs verbosity-                               (vcsProgram vcs) repo-                               srcuri destdir----- | Syncronise a set of 'SourceRepo's referring to the same repository with--- corresponding local directories. The local directories may or may not--- already exist.------ The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',--- or used across a series of invocations with any local directory must refer--- to the /same/ repository. That means it must be the same location but they--- can differ in the branch, or tag or subdir.------ The reason to allow multiple related 'SourceRepo's is to allow for the--- network or storage to be shared between different checkouts of the repo.--- For example if a single repo contains multiple packages in different subdirs--- and in some project it may make sense to use a different state of the repo--- for one subdir compared to another.----syncSourceRepos :: Verbosity-                -> VCS ConfiguredProgram-                -> [(SourceRepositoryPackage f, FilePath)]-                -> Rebuild ()-syncSourceRepos verbosity vcs repos = do-    files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos-    monitorFiles files----- --------------------------------------------------------------- * The various VCS drivers--- ---------------------------------------------------------------- | The set of all supported VCS drivers, organised by 'RepoType'.----knownVCSs :: Map RepoType (VCS Program)-knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]-  where-    vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]----- | VCS driver for Bazaar.----vcsBzr :: VCS Program-vcsBzr =-    VCS {-      vcsRepoType = KnownRepoType Bazaar,-      vcsProgram  = bzrProgram,-      vcsCloneRepo,-      vcsSyncRepos-    }-  where-    vcsCloneRepo :: Verbosity-                 -> ConfiguredProgram-                 -> SourceRepositoryPackage f-                 -> FilePath-                 -> FilePath-                 -> [ProgramInvocation]-    vcsCloneRepo verbosity prog repo srcuri destdir =-        [ programInvocation prog-            ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ]-      where-        -- The @get@ command was deprecated in version 2.4 in favour of-        -- the alias @branch@-        branchCmd | programVersion prog >= Just (mkVersion [2,4])-                              = "branch"-                  | otherwise = "get"--        tagArgs = case srpTag repo of-          Nothing  -> []-          Just tag -> ["-r", "tag:" ++ tag]-        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]--    vcsSyncRepos :: Verbosity -> ConfiguredProgram-                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"--bzrProgram :: Program-bzrProgram = (simpleProgram "bzr") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- "Bazaar (bzr) 2.6.0\n  ... lots of extra stuff"-        (_:_:ver:_) -> ver-        _ -> ""-  }----- | VCS driver for Darcs.----vcsDarcs :: VCS Program-vcsDarcs =-    VCS {-      vcsRepoType = KnownRepoType Darcs,-      vcsProgram  = darcsProgram,-      vcsCloneRepo,-      vcsSyncRepos-    }-  where-    vcsCloneRepo :: Verbosity-                 -> ConfiguredProgram-                 -> SourceRepositoryPackage f-                 -> FilePath-                 -> FilePath-                 -> [ProgramInvocation]-    vcsCloneRepo verbosity prog repo srcuri destdir =-        [ programInvocation prog cloneArgs ]-      where-        cloneArgs  = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg-        -- At some point the @clone@ command was introduced as an alias for-        -- @get@, and @clone@ seems to be the recommended one now.-        cloneCmd   | programVersion prog >= Just (mkVersion [2,8])-                               = "clone"-                   | otherwise = "get"-        tagArgs    = case srpTag repo of-          Nothing  -> []-          Just tag -> ["-t", tag]-        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]--    vcsSyncRepos :: Verbosity -> ConfiguredProgram-                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"--darcsProgram :: Program-darcsProgram = (simpleProgram "darcs") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- "2.8.5 (release)"-        (ver:_) -> ver-        _ -> ""-  }----- | VCS driver for Git.----vcsGit :: VCS Program-vcsGit =-    VCS {-      vcsRepoType = KnownRepoType Git,-      vcsProgram  = gitProgram,-      vcsCloneRepo,-      vcsSyncRepos-    }-  where-    vcsCloneRepo :: Verbosity-                 -> ConfiguredProgram-                 -> SourceRepositoryPackage f-                 -> FilePath-                 -> FilePath-                 -> [ProgramInvocation]-    vcsCloneRepo verbosity prog repo srcuri destdir =-        [ programInvocation prog cloneArgs ]-        -- And if there's a tag, we have to do that in a second step:-     ++ [ (programInvocation prog (checkoutArgs tag)) {-            progInvokeCwd = Just destdir-          }-        | tag <- maybeToList (srpTag repo) ]-      where-        cloneArgs  = ["clone", srcuri, destdir]-                     ++ branchArgs ++ verboseArg-        branchArgs = case srpBranch repo of-          Just b  -> ["--branch", b]-          Nothing -> []-        checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]-        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]--    vcsSyncRepos :: Verbosity-                 -> ConfiguredProgram-                 -> [(SourceRepositoryPackage f, FilePath)]-                 -> IO [MonitorFilePath]-    vcsSyncRepos _ _ [] = return []-    vcsSyncRepos verbosity gitProg-                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do--      vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing-      sequence_-        [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)-        | (repo, localDir) <- secondaryRepos ]-      return [ monitorDirectoryExistence dir-             | dir <- (primaryLocalDir : map snd secondaryRepos) ]--    vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do-        exists <- doesDirectoryExist localDir-        if exists-          then git localDir                 ["fetch"]-          else git (takeDirectory localDir) cloneArgs-        git localDir checkoutArgs-      where-        git :: FilePath -> [String] -> IO ()-        git cwd args = runProgramInvocation verbosity $-                         (programInvocation gitProg args) {-                           progInvokeCwd = Just cwd-                         }--        cloneArgs      = ["clone", "--no-checkout", loc, localDir]-                      ++ case peer of-                           Nothing           -> []-                           Just peerLocalDir -> ["--reference", peerLocalDir]-                      ++ verboseArg-                         where loc = srpLocation-        checkoutArgs   = "checkout" : verboseArg ++ ["--detach", "--force"-                         , checkoutTarget, "--" ]-        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)-        verboseArg     = [ "--quiet" | verbosity < Verbosity.normal ]--gitProgram :: Program-gitProgram = (simpleProgram "git") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- "git version 2.5.5"-        (_:_:ver:_) | all isTypical ver -> ver--        -- or annoyingly "git version 2.17.1.windows.2" yes, really-        (_:_:ver:_) -> intercalate "."-                     . takeWhile (all isNum)-                     . split-                     $ ver-        _ -> ""-  }-  where-    isNum     c = c >= '0' && c <= '9'-    isTypical c = isNum c || c == '.'-    split    cs = case break (=='.') cs of-                    (chunk,[])     -> chunk : []-                    (chunk,_:rest) -> chunk : split rest---- | VCS driver for Mercurial.----vcsHg :: VCS Program-vcsHg =-    VCS {-      vcsRepoType = KnownRepoType Mercurial,-      vcsProgram  = hgProgram,-      vcsCloneRepo,-      vcsSyncRepos-    }-  where-    vcsCloneRepo :: Verbosity-                 -> ConfiguredProgram-                 -> SourceRepositoryPackage f-                 -> FilePath-                 -> FilePath-                 -> [ProgramInvocation]-    vcsCloneRepo verbosity prog repo srcuri destdir =-        [ programInvocation prog cloneArgs ]-      where-        cloneArgs  = ["clone", srcuri, destdir]-                     ++ branchArgs ++ tagArgs ++ verboseArg-        branchArgs = case srpBranch repo of-          Just b  -> ["--branch", b]-          Nothing -> []-        tagArgs = case srpTag repo of-          Just t  -> ["--rev", t]-          Nothing -> []-        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]--    vcsSyncRepos :: Verbosity-                 -> ConfiguredProgram-                 -> [(SourceRepositoryPackage f, FilePath)]-                 -> IO [MonitorFilePath]-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"--hgProgram :: Program-hgProgram = (simpleProgram "hg") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- Mercurial Distributed SCM (version 3.5.2)\n ... long message-        (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver-        _ -> ""-  }----- | VCS driver for Subversion.----vcsSvn :: VCS Program-vcsSvn =-    VCS {-      vcsRepoType = KnownRepoType SVN,-      vcsProgram  = svnProgram,-      vcsCloneRepo,-      vcsSyncRepos-    }-  where-    vcsCloneRepo :: Verbosity-                 -> ConfiguredProgram-                 -> SourceRepositoryPackage f-                 -> FilePath-                 -> FilePath-                 -> [ProgramInvocation]-    vcsCloneRepo verbosity prog _repo srcuri destdir =-        [ programInvocation prog checkoutArgs ]-      where-        checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg-        verboseArg   = [ "--quiet" | verbosity < Verbosity.normal ]-        --TODO: branch or tag?--    vcsSyncRepos :: Verbosity-                 -> ConfiguredProgram-                 -> [(SourceRepositoryPackage f, FilePath)]-                 -> IO [MonitorFilePath]-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"--svnProgram :: Program-svnProgram = (simpleProgram "svn") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- svn, version 1.9.4 (r1740329)\n ... long message-        (_:_:ver:_) -> ver-        _ -> ""-  }----- | VCS driver for Pijul.--- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>------ 2020-04-09 Oleg:------    As far as I understand pijul, there are branches and "tags" in pijul,---    but there aren't a "commit hash" identifying an arbitrary state.------    One can create `a pijul tag`, which will make a patch hash,---    which depends on everything currently in the repository.---    I guess if you try to apply that patch, you'll be forced to apply---    all the dependencies too. In other words, there are no named tags.------    It's not clear to me whether there is an option to---    "apply this patch *and* all of its dependencies".---    And relatedly, whether how to make sure that there are no other---    patches applied.------    With branches it's easier, as you can `pull` and `checkout` them,---    and they seem to be similar enough. Yet, pijul documentations says------    > Note that the purpose of branches in Pijul is quite different from Git,---      since Git's "feature branches" can usually be implemented by just---      patches.------    I guess it means that indeed instead of creating a branch and making PR---    in "GitHub" workflow, you'd just create a patch and offer it.---    You can do that with `git` too. Push (a branch with) commit to remote---    and ask other to cherry-pick that commit. Yet, in git identity of commit---    changes when it applied to other trees, where patches in pijul have---    will continue to have the same hash.------    Unfortunately pijul doesn't talk about conflict resolution.---    It seems that you get something like:------        % pijul status---        On branch merge------        Unresolved conflicts:---          (fix conflicts and record the resolution with "pijul record ...")------                foo------        % cat foo---        first line---        >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>---        branch BBB---        ================================---        branch AAA---        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<---        last line------    And then the `pijul dependencies` would draw you a graph like---------                    ----->  foo on branch B ----->---    resolve confict                                  Initial patch---                    ----->  foo on branch A ----->------    Which is seems reasonable.------    So currently, pijul support is very experimental, and most likely---    won't work, even the basics are in place. Tests are also written---    but disabled, as the branching model differs from `git` one,---    for which tests are written.----vcsPijul :: VCS Program-vcsPijul =-    VCS {-      vcsRepoType = KnownRepoType Pijul,-      vcsProgram  = pijulProgram,-      vcsCloneRepo,-      vcsSyncRepos-    }-  where-    vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag-                 -> ConfiguredProgram-                 -> SourceRepositoryPackage f-                 -> FilePath-                 -> FilePath-                 -> [ProgramInvocation]-    vcsCloneRepo _verbosity prog repo srcuri destdir =-        [ programInvocation prog cloneArgs ]-        -- And if there's a tag, we have to do that in a second step:-     ++ [ (programInvocation prog (checkoutArgs tag)) {-            progInvokeCwd = Just destdir-          }-        | tag <- maybeToList (srpTag repo) ]-      where-        cloneArgs  = ["clone", srcuri, destdir]-                     ++ branchArgs-        branchArgs = case srpBranch repo of-          Just b  -> ["--from-branch", b]-          Nothing -> []-        checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either--    vcsSyncRepos :: Verbosity-                 -> ConfiguredProgram-                 -> [(SourceRepositoryPackage f, FilePath)]-                 -> IO [MonitorFilePath]-    vcsSyncRepos _ _ [] = return []-    vcsSyncRepos verbosity pijulProg-                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do--      vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing-      sequence_-        [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)-        | (repo, localDir) <- secondaryRepos ]-      return [ monitorDirectoryExistence dir-             | dir <- (primaryLocalDir : map snd secondaryRepos) ]--    vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do-        exists <- doesDirectoryExist localDir-        if exists-        then pijul localDir                 ["pull"] -- TODO: this probably doesn't work.-        else pijul (takeDirectory localDir) cloneArgs-        pijul localDir checkoutArgs-      where-        pijul :: FilePath -> [String] -> IO ()-        pijul cwd args = runProgramInvocation verbosity $-                         (programInvocation pijulProg args) {-                           progInvokeCwd = Just cwd-                         }--        cloneArgs      = ["clone", loc, localDir]-                      ++ case peer of-                           Nothing           -> []-                           Just peerLocalDir -> [peerLocalDir]-                         where loc = srpLocation-        checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]-        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.--pijulProgram :: Program-pijulProgram = (simpleProgram "pijul") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      case words str of-        -- "pijul 0.12.2-        (_:ver:_) | all isTypical ver -> ver-        _ -> ""-  }-  where-    isNum     c = c >= '0' && c <= '9'-    isTypical c = isNum c || c == '.'
− Distribution/Client/Win32SelfUpgrade.hs 
@@ -1,226 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Win32SelfUpgrade--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Support for self-upgrading executables on Windows platforms.-------------------------------------------------------------------------------module Distribution.Client.Win32SelfUpgrade (--- * Explanation------ | Windows inherited a design choice from DOS that while initially innocuous--- has rather unfortunate consequences. It maintains the invariant that every--- open file has a corresponding name on disk. One positive consequence of this--- is that an executable can always find its own executable file. The downside--- is that a program cannot be deleted or upgraded while it is running without--- hideous workarounds. This module implements one such hideous workaround.------ The basic idea is:------ * 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--- * Wait for the new process to start--- * Close the new exe file--- * Exit old process------ Then in the new process:------ * Inform the old process that we've started--- * Wait for the old process to die--- * Delete the old exe file--- * Exit new process-----    possibleSelfUpgrade,-    deleteOldExeFile,-  ) where--import Distribution.Client.Compat.Prelude hiding (log)-import Prelude ()--#ifdef mingw32_HOST_OS--import qualified System.Win32 as Win32-import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)-import Foreign.Ptr (Ptr, nullPtr)-import System.Process (runProcess)-import System.Directory (canonicalizePath)-import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)--import Distribution.Verbosity as Verbosity (showForCabal)-import Distribution.Simple.Utils (debug, info)----- | If one of the given files is our own exe file then we arrange things such--- 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.----possibleSelfUpgrade :: Verbosity-                    -> [FilePath]-                    -> IO a -> IO a-possibleSelfUpgrade verbosity newPaths action = do-  dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE--  newPaths' <- traverse canonicalizePath newPaths-  let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'--  if not doingSelfUpgrade-    then action-    else do-      info verbosity $ "cabal-install does the replace-own-exe-file dance..."-      tmpPath <- moveOurExeOutOfTheWay verbosity-      result <- action-      scheduleOurDemise verbosity dstPath tmpPath-        (\pid path -> ["win32selfupgrade", pid, path-                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])-      return result---- | The name of a Win32 Event object that we use to synchronise between the--- 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--- re-used).----syncEventName :: String-syncEventName = "Local\\cabal-install-upgrade"---- | The first part of allowing our exe file to be replaced is to move the--- existing exe file out of the way. Although we cannot delete our exe file--- while we're still running, fortunately we can rename it, at least within--- the same directory.----moveOurExeOutOfTheWay :: Verbosity -> IO FilePath-moveOurExeOutOfTheWay verbosity = do-  ourPID  <-       getCurrentProcessId-  dstPath <- Win32.getModuleFileName Win32.nullHANDLE--  let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)--  debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath-  Win32.moveFile dstPath tmpPath-  return tmpPath---- | Assuming we've now installed the new exe file in the right place, we--- launch it and ask it to delete our exe file when we eventually terminate.----scheduleOurDemise :: Verbosity -> FilePath -> FilePath-                  -> (String -> FilePath -> [String]) -> IO ()-scheduleOurDemise verbosity dstPath tmpPath mkArgs = do-  ourPID <- getCurrentProcessId-  event  <- createEvent syncEventName--  let args = mkArgs (show ourPID) tmpPath-  log $ "launching child " ++ unwords (dstPath : map show args)-  _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing--  log $ "waiting for the child to start up"-  waitForSingleObject event (10*1000) -- wait at most 10 sec-  log $ "child started ok"--  where-    log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)---- | 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 renamed itself to.----deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()-deleteOldExeFile verbosity oldPID tmpPath = do-  log $ "process started. Will delete exe file of process "-     ++ show oldPID ++ " at path " ++ tmpPath--  log $ "getting handle of parent process " ++ show oldPID-  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)--  log $ "synchronising with parent"-  event <- openEvent syncEventName-  setEvent event--  log $ "waiting for parent process to terminate"-  waitForSingleObject oldPHANDLE Win32.iNFINITE-  log $ "parent process terminated"--  log $ "deleting parent's old .exe file"-  Win32.deleteFile tmpPath--  where-    log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)----------------------------- Win32 foreign imports------- A bunch of functions sadly not provided by the Win32 package.--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "windows.h GetCurrentProcessId"-  getCurrentProcessId :: IO DWORD--foreign import CALLCONV unsafe "windows.h WaitForSingleObject"-  waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD--waitForSingleObject :: HANDLE -> DWORD -> IO ()-waitForSingleObject handle timeout =-  Win32.failIf_ bad "WaitForSingleObject" $-    waitForSingleObject_ handle timeout-  where-    bad result   = not (result == 0 || result == wAIT_TIMEOUT)-    wAIT_TIMEOUT = 0x00000102--foreign import CALLCONV unsafe "windows.h CreateEventW"-  createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE--createEvent :: String -> IO HANDLE-createEvent name = do-  Win32.failIfNull "CreateEvent" $-    Win32.withTString name $-      createEvent_ nullPtr False False--foreign import CALLCONV unsafe "windows.h OpenEventW"-  openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE--openEvent :: String -> IO HANDLE-openEvent name = do-  Win32.failIfNull "OpenEvent" $-    Win32.withTString name $-      openEvent_ eVENT_MODIFY_STATE False-  where-    eVENT_MODIFY_STATE :: DWORD-    eVENT_MODIFY_STATE = 0x0002--foreign import CALLCONV unsafe "windows.h SetEvent"-  setEvent_ :: HANDLE -> IO BOOL--setEvent :: HANDLE -> IO ()-setEvent handle =-  Win32.failIfFalse_ "SetEvent" $-    setEvent_ handle--#else--import Distribution.Simple.Utils (die')--possibleSelfUpgrade :: Verbosity-                    -> [FilePath]-                    -> IO a -> IO a-possibleSelfUpgrade _ _ action = action--deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()-deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32"--#endif
− Distribution/Client/World.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.World--- Copyright   :  (c) Peter Robinson 2009--- License     :  BSD-like------ Maintainer  :  thaldyron@gmail.com--- Stability   :  provisional--- Portability :  portable------ Interface to the world-file that contains a list of explicitly--- requested packages. Meant to be imported qualified.------ A world file entry stores the package-name, package-version, and--- user flags.--- For example, the entry generated by--- # cabal install stm-io-hooks --flags="-debug"--- looks like this:--- # stm-io-hooks -any --flags="-debug"--- To rebuild/upgrade the packages in world (e.g. when updating the compiler)--- use--- # cabal install world----------------------------------------------------------------------------------module Distribution.Client.World (-    WorldPkgInfo(..),-    insert,-    delete,-    getContents,-  ) where--import Prelude (sequence)-import Distribution.Client.Compat.Prelude hiding (getContents)--import Distribution.Types.Dependency-import Distribution.Types.Flag-         ( FlagAssignment, unFlagAssignment-         , unFlagName, parsecFlagAssignmentNonEmpty )-import Distribution.Simple.Utils-         ( die', info, chattyTry, writeFileAtomic )-import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as Disp--import Data.List-         ( unionBy, deleteFirstsBy )-import System.IO.Error-         ( isDoesNotExistError )-import qualified Data.ByteString.Lazy.Char8 as B---data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment-  deriving (Show,Eq, Generic)---- | Adds packages to the world file; creates the file if it doesn't--- exist yet. Version constraints and flag assignments for a package are--- updated if already present. IO errors are non-fatal.-insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()-insert = modifyWorld $ unionBy equalUDep---- | Removes packages from the world file.--- Note: Currently unused as there is no mechanism in Cabal (yet) to--- handle uninstalls. IO errors are non-fatal.-delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()-delete = modifyWorld $ flip (deleteFirstsBy equalUDep)---- | WorldPkgInfo values are considered equal if they refer to--- the same package, i.e., we don't care about differing versions or flags.-equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool-equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _)-          (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2---- | Modifies the world file by applying an update-function ('unionBy'--- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of--- packages. IO errors are considered non-fatal.-modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]-                -> [WorldPkgInfo])-                        -- ^ Function that defines how-                        -- the list of user packages are merged with-                        -- existing world packages.-            -> Verbosity-            -> FilePath               -- ^ Location of the world file-            -> [WorldPkgInfo] -- ^ list of user supplied packages-            -> IO ()-modifyWorld _ _         _     []   = return ()-modifyWorld f verbosity world pkgs =-  chattyTry "Error while updating world-file. " $ do-    pkgsOldWorld <- getContents verbosity world-    -- Filter out packages that are not in the world file:-    let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld-    -- 'Dependency' is not an Ord instance, so we need to check for-    -- equivalence the awkward way:-    if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&-            all (`elem` pkgsNewWorld) pkgsOldWorld)-      then do-        info verbosity "Updating world file..."-        writeFileAtomic world . B.pack $ unlines-            [ (prettyShow pkg) | pkg <- pkgsNewWorld]-      else-        info verbosity "World file is already up to date."----- | Returns the content of the world file as a list-getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]-getContents verbosity world = do-  content <- safelyReadFile world-  let result = map simpleParsec (lines $ B.unpack content)-  case sequence result of-    Nothing -> die' verbosity "Could not parse world file."-    Just xs -> return xs-  where-  safelyReadFile :: FilePath -> IO B.ByteString-  safelyReadFile file = B.readFile file `catchIO` handler-    where-      handler e | isDoesNotExistError e = return B.empty-                | otherwise             = ioError e---instance Pretty WorldPkgInfo where-  pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags)-    where-      dispFlags [] = Disp.empty-      dispFlags fs = Disp.text "--flags="-                  <<>> Disp.doubleQuotes (flagAssToDoc fs)-      flagAssToDoc = foldr (\(fname,val) flagAssDoc ->-                             (if not val then Disp.char '-'-                                         else Disp.char '+')-                             <<>> Disp.text (unFlagName fname)-                             Disp.<+> flagAssDoc)-                           Disp.empty--instance Parsec WorldPkgInfo where-  parsec = do-      dep <- parsec-      P.spaces-      flagAss <- P.option mempty parseFlagAssignment-      return $ WorldPkgInfo dep flagAss-    where-      parseFlagAssignment :: CabalParsing m => m FlagAssignment-      parseFlagAssignment = do-          _ <- P.string "--flags="-          inDoubleQuotes parsecFlagAssignmentNonEmpty-        where-          inDoubleQuotes = P.between (P.char '"') (P.char '"')
− Distribution/Deprecated/ParseUtils.hs 
@@ -1,563 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Deprecated.ParseUtils--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.------ The @.cabal@ file format is not trivial, especially with the introduction--- of configurations and the section syntax that goes with that. This module--- has a bunch of parsing functions that is used by the @.cabal@ parser and a--- couple others. It has the parsing framework code and also little parsers for--- many of the formats we get in various @.cabal@ file fields, like module--- names, comma separated lists etc.---- This module is meant to be local-only to Distribution...--{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE Rank2Types #-}-module Distribution.Deprecated.ParseUtils (-        LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,-        runP, runE, ParseResult(..), parseFail, showPWarning,-        Field(..), lineNo,-        FieldDescr(..), readFields, readFieldsFlat,-        parseHaskellString, parseFilePathQ, parseTokenQ,-        parseOptCommaList,-        showFilePath, showToken, showFreeText,-        field, simpleField, listField, listFieldWithSep, spaceListField,-        newLineListField,-        liftField,-        readPToMaybe,--        fieldParsec, simpleFieldParsec,-        listFieldParsec,-        commaListFieldParsec,-        commaNewLineListFieldParsec,--        UnrecFieldParser,-  ) where--import Distribution.Client.Compat.Prelude hiding (get)-import Prelude ()--import Distribution.Deprecated.ReadP as ReadP hiding (get)--import Distribution.Pretty-import Distribution.ReadE-import Distribution.Utils.Generic--import Data.Tree as Tree (Tree (..), flatten)-import System.FilePath  (normalise)-import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep)-import qualified Text.Read as Read--import qualified Control.Monad.Fail as Fail-import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList)---- -------------------------------------------------------------------------------type LineNo    = Int--data PError = AmbiguousParse String LineNo-            | NoParse String LineNo-            | TabsError LineNo-            | FromString String (Maybe LineNo)-        deriving (Eq, Show)--data PWarning = PWarning String-              | UTFWarning LineNo String-        deriving (Eq, Show)--showPWarning :: FilePath -> PWarning -> String-showPWarning fpath (PWarning msg) =-  normalise fpath ++ ": " ++ msg-showPWarning fpath (UTFWarning line fname) =-  normalise fpath ++ ":" ++ show line-        ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."--data ParseResult a = ParseFailed PError | ParseOk [PWarning] a-        deriving Show--instance Functor ParseResult where-        fmap _ (ParseFailed err) = ParseFailed err-        fmap f (ParseOk ws x) = ParseOk ws $ f x--instance Applicative ParseResult where-        pure = ParseOk []-        (<*>) = ap---instance Monad ParseResult where-        return = pure-        ParseFailed err >>= _ = ParseFailed err-        ParseOk ws x >>= f = case f x of-                               ParseFailed err -> ParseFailed err-                               ParseOk ws' x' -> ParseOk (ws'++ws) x'--#if !(MIN_VERSION_base(4,9,0))-        fail = parseResultFail-#elif !(MIN_VERSION_base(4,13,0))-        fail = Fail.fail-#endif--instance Fail.MonadFail ParseResult where-        fail = parseResultFail--parseResultFail :: String -> ParseResult a-parseResultFail s = parseFail (FromString s Nothing)--parseFail :: PError -> ParseResult a-parseFail = ParseFailed--runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a-runP line fieldname p s =-  case [ x | (x,"") <- results ] of-    [a] -> ParseOk (utf8Warnings line fieldname s) a-    --TODO: what is this double parse thing all about?-    --      Can't we just do the all isSpace test the first time?-    []  -> case [ x | (x,ys) <- results, all isSpace ys ] of-             [a] -> ParseOk (utf8Warnings line fieldname s) a-             []  -> ParseFailed (NoParse fieldname line)-             _   -> ParseFailed (AmbiguousParse fieldname line)-    _   -> ParseFailed (AmbiguousParse fieldname line)-  where results = readP_to_S p s--runE :: LineNo -> String -> ReadE a -> String -> ParseResult a-runE line fieldname p s =-    case runReadE p s of-      Right a -> ParseOk (utf8Warnings line fieldname s) a-      Left  e -> syntaxError line $-        "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s--utf8Warnings :: LineNo -> String -> String -> [PWarning]-utf8Warnings line fieldname s =-  take 1 [ UTFWarning n fieldname-         | (n,l) <- zip [line..] (lines s)-         , '\xfffd' `elem` l ]--locatedErrorMsg :: PError -> (Maybe LineNo, String)-locatedErrorMsg (AmbiguousParse f n) = (Just n,-                                        "Ambiguous parse in field '"++f++"'.")-locatedErrorMsg (NoParse f n)        = (Just n,-                                        "Parse of field '"++f++"' failed.")-locatedErrorMsg (TabsError n)        = (Just n, "Tab used as indentation.")-locatedErrorMsg (FromString s n)     = (n, s)--syntaxError :: LineNo -> String -> ParseResult a-syntaxError n s = ParseFailed $ FromString s (Just n)--tabsError :: LineNo -> ParseResult a-tabsError ln = ParseFailed $ TabsError ln--warning :: String -> ParseResult ()-warning s = ParseOk [PWarning s] ()---- | Field descriptor.  The parameter @a@ parameterizes over where the field's---   value is stored in.-data FieldDescr a-  = FieldDescr-      { fieldName     :: String-      , fieldGet      :: a -> Doc-      , fieldSet      :: LineNo -> String -> a -> ParseResult a-        -- ^ @fieldSet n str x@ Parses the field value from the given input-        -- string @str@ and stores the result in @x@ if the parse was-        -- successful.  Otherwise, reports an error on line number @n@.-      }--field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a-field name showF readF =-  FieldDescr name showF (\line val _st -> runP line name readF val)--fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a-fieldParsec name showF readF =-  FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of-    Left err -> ParseFailed (FromString err (Just line))-    Right x  -> ParseOk [] x---- Lift a field descriptor storing into an 'a' to a field descriptor storing--- into a 'b'.-liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b-liftField get set (FieldDescr name showF parseF)- = FieldDescr name (showF . get)-        (\line str b -> do-            a <- parseF line str (get b)-            return (set a b))---- Parser combinator for simple fields.  Takes a field name, a pretty printer,--- a parser function, an accessor, and a setter, returns a FieldDescr over the--- compoid structure.-simpleField :: String -> (a -> Doc) -> ReadP a a-            -> (b -> a) -> (a -> b -> b) -> FieldDescr b-simpleField name showF readF get set-  = liftField get set $ field name showF readF--simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a-            -> (b -> a) -> (a -> b -> b) -> FieldDescr b-simpleFieldParsec name showF readF get set-  = liftField get set $ fieldParsec name showF readF--commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a-                      -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListFieldWithSepParsec separator name showF readF get set =-   liftField get set' $-     fieldParsec name showF' (parsecLeadingCommaList readF)-   where-     set' xs b = set (get b ++ xs) b-     showF'    = separator . punctuate comma . map showF--commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListFieldParsec = commaListFieldWithSepParsec fsep--commaNewLineListFieldParsec-    :: String -> (a -> Doc) ->  ParsecParser a-    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaNewLineListFieldParsec = commaListFieldWithSepParsec sep--spaceListField :: String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-spaceListField name showF readF get set =-  liftField get set' $-    field name showF' (parseSpaceList readF)-  where-    set' xs b = set (get b ++ xs) b-    showF'    = fsep . map showF---- this is a different definition from listField, like--- commaNewLineListField it pretty prints on multiple lines-newLineListField :: String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-newLineListField = listFieldWithSep sep--listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listFieldWithSep separator name showF readF get set =-  liftField get set' $-    field name showF' (parseOptCommaList readF)-  where-    set' xs b = set (get b ++ xs) b-    showF'    = separator . map showF--listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listFieldWithSepParsec separator name showF readF get set =-  liftField get set' $-    fieldParsec name showF' (parsecLeadingOptCommaList readF)-  where-    set' xs b = set (get b ++ xs) b-    showF'    = separator . map showF--listField :: String -> (a -> Doc) -> ReadP [a] a-          -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listField = listFieldWithSep fsep--listFieldParsec-    :: String -> (a -> Doc) -> ParsecParser a-    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listFieldParsec = listFieldWithSepParsec fsep---- | The type of a function which, given a name-value pair of an---   unrecognized field, and the current structure being built,---   decides whether to incorporate the unrecognized field---   (by returning  Just x, where x is a possibly modified version---   of the structure being built), or not (by returning Nothing).-type UnrecFieldParser a = (String,String) -> a -> Maybe a------------------------------------------------------------------------------------ The data type for our three syntactic categories-data Field-    = F LineNo String String-      -- ^ A regular @<property>: <value>@ field-    | Section LineNo String String [Field]-      -- ^ A section with a name and possible parameter.  The syntactic-      -- structure is:-      ---      -- @-      --   <sectionname> <arg> {-      --     <field>*-      --   }-      -- @-    | IfBlock LineNo String [Field] [Field]-      -- ^ A conditional block with an optional else branch:-      ---      -- @-      --  if <condition> {-      --    <field>*-      --  } else {-      --    <field>*-      --  }-      -- @-      deriving (Show-               ,Eq)   -- for testing--lineNo :: Field -> LineNo-lineNo (F n _ _) = n-lineNo (Section n _ _ _) = n-lineNo (IfBlock n _ _ _) = n--readFields :: String -> ParseResult [Field]-readFields input = ifelse-               =<< traverse (mkField 0)-               =<< mkTree tokens--  where ls = (lines . normaliseLineEndings) input-        tokens = (concatMap tokeniseLine . trimLines) ls--readFieldsFlat :: String -> ParseResult [Field]-readFieldsFlat input = traverse (mkField 0)-                   =<< mkTree tokens-  where ls = (lines . normaliseLineEndings) input-        tokens = (concatMap tokeniseLineFlat . trimLines) ls---- attach line number and determine indentation-trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]-trimLines ls = [ (lineno, indent, hastabs, trimTrailing l')-               | (lineno, l) <- zip [1..] ls-               , let (sps, l') = span isSpace l-                     indent    = length sps-                     hastabs   = '\t' `elem` sps-               , validLine l' ]-  where validLine ('-':'-':_) = False      -- Comment-        validLine []          = False      -- blank line-        validLine _           = True---- | We parse generically based on indent level and braces '{' '}'. To do that--- we split into lines and then '{' '}' tokens and other spans within a line.-data Token =-       -- | The 'Line' token is for bits that /start/ a line, eg:-       ---       -- > "\n  blah blah { blah"-       ---       -- tokenises to:-       ---       -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]-       ---       -- so lines are the only ones that can have nested layout, since they-       -- have a known indentation level.-       ---       -- eg: we can't have this:-       ---       -- > if ... {-       -- > } else-       -- >     other-       ---       -- because other cannot nest under else, since else doesn't start a line-       -- so cannot have nested layout. It'd have to be:-       ---       -- > if ... {-       -- > }-       -- >   else-       -- >     other-       ---       -- but that's not so common, people would normally use layout or-       -- brackets not both in a single @if else@ construct.-       ---       -- > if ... { foo : bar }-       -- > else-       -- >    other-       ---       -- this is OK-       Line LineNo Indent HasTabs String-     | Span LineNo                String  -- ^ span in a line, following brackets-     | OpenBracket LineNo | CloseBracket LineNo--type Indent = Int-type HasTabs = Bool---- | Tokenise a single line, splitting on '{' '}' and the spans in between.--- Also trims leading & trailing space on those spans within the line.-tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token]-tokeniseLine (n0, i, t, l) = case split n0 l of-                            (Span _ l':ss) -> Line n0 i t l' :ss-                            cs              -> cs-  where split _ "" = []-        split n s  = case span (\c -> c /='}' && c /= '{') s of-          ("", '{' : s') ->             OpenBracket  n : split n s'-          (w , '{' : s') -> mkspan n w (OpenBracket  n : split n s')-          ("", '}' : s') ->             CloseBracket n : split n s'-          (w , '}' : s') -> mkspan n w (CloseBracket n : split n s')-          (w ,        _) -> mkspan n w []--        mkspan n s ss | null s'   =             ss-                      | otherwise = Span n s' : ss-          where s' = trimTrailing (trimLeading s)--tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]-tokeniseLineFlat (n0, i, t, l)-  | null l'   = []-  | otherwise = [Line n0 i t l']-  where-    l' = trimTrailing (trimLeading l)--trimLeading, trimTrailing :: String -> String-trimLeading  = dropWhile isSpace-trimTrailing = dropWhileEndLE isSpace---type SyntaxTree = Tree (LineNo, HasTabs, String)---- | Parse the stream of tokens into a tree of them, based on indent \/ layout-mkTree :: [Token] -> ParseResult [SyntaxTree]-mkTree toks =-  layout 0 [] toks >>= \(trees, trailing) -> case trailing of-    []               -> return trees-    OpenBracket  n:_ -> syntaxError n "mismatched brackets, unexpected {"-    CloseBracket n:_ -> syntaxError n "mismatched brackets, unexpected }"-    -- the following two should never happen:-    Span n     l  :_ -> syntaxError n $ "unexpected span: " ++ show l-    Line n _ _ l  :_ -> syntaxError n $ "unexpected line: " ++ show l----- | Parse the stream of tokens into a tree of them, based on indent--- This parse state expect to be in a layout context, though possibly--- nested within a braces context so we may still encounter closing braces.-layout :: Indent       -- ^ indent level of the parent\/previous line-       -> [SyntaxTree] -- ^ accumulating param, trees in this level-       -> [Token]      -- ^ remaining tokens-       -> ParseResult ([SyntaxTree], [Token])-                       -- ^ collected trees on this level and trailing tokens-layout _ a []                               = return (reverse a, [])-layout i a (s@(Line _ i' _ _):ss) | i' < i  = return (reverse a, s:ss)-layout i a (Line n _ t l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    layout i (Node (n,t,l) sub:a) ss'--layout i a (Span n     l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    layout i (Node (n,False,l) sub:a) ss'---- look ahead to see if following lines are more indented, giving a sub-tree-layout i a (Line n i' t l:ss) = do-    lookahead <- layout (i'+1) [] ss-    case lookahead of-        ([], _)   -> layout i (Node (n,t,l) [] :a) ss-        (ts, ss') -> layout i (Node (n,t,l) ts :a) ss'--layout _ _ (   OpenBracket  n :_)  = syntaxError n "unexpected '{'"-layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss)-layout _ _ (   Span n l       : _) = syntaxError n $ "unexpected span: "-                                                  ++ show l---- | Parse the stream of tokens into a tree of them, based on explicit braces--- This parse state expects to find a closing bracket.-braces :: LineNo       -- ^ line of the '{', used for error messages-       -> [SyntaxTree] -- ^ accumulating param, trees in this level-       -> [Token]      -- ^ remaining tokens-       -> ParseResult ([SyntaxTree],[Token])-                       -- ^ collected trees on this level and trailing tokens-braces m a (Line n _ t l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    braces m (Node (n,t,l) sub:a) ss'--braces m a (Span n     l:OpenBracket n':ss) = do-    (sub, ss') <- braces n' [] ss-    braces m (Node (n,False,l) sub:a) ss'--braces m a (Line n i t l:ss) = do-    lookahead <- layout (i+1) [] ss-    case lookahead of-        ([], _)   -> braces m (Node (n,t,l) [] :a) ss-        (ts, ss') -> braces m (Node (n,t,l) ts :a) ss'--braces m a (Span n       l:ss) = braces m (Node (n,False,l) []:a) ss-braces _ a (CloseBracket _:ss) = return (reverse a, ss)-braces n _ []                  = syntaxError n $ "opening brace '{'"-                              ++ "has no matching closing brace '}'"-braces _ _ (OpenBracket  n:_)  = syntaxError n "unexpected '{'"---- | Convert the parse tree into the Field AST--- Also check for dodgy uses of tabs in indentation.-mkField :: Int -> SyntaxTree -> ParseResult Field-mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n-mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of-  ([], _)       -> syntaxError n $ "unrecognised field or section: " ++ show l-  (name, rest)  -> case trimLeading rest of-    (':':rest') -> do let followingLines = concatMap Tree.flatten ts-                          tabs = not (null [()| (_,True,_) <- followingLines ])-                      if tabs && d >= 1-                        then tabsError n-                        else return $ F n (map toLower name)-                                          (fieldValue rest' followingLines)-    rest'       -> do ts' <- traverse (mkField (d+1)) ts-                      return (Section n (map toLower name) rest' ts')- where    fieldValue firstLine followingLines =-            let firstLine' = trimLeading firstLine-                followingLines' = map (\(_,_,s) -> stripDot s) followingLines-                allLines | null firstLine' =              followingLines'-                         | otherwise       = firstLine' : followingLines'-             in intercalate "\n" allLines-          stripDot "." = ""-          stripDot s   = s---- | Convert if/then/else 'Section's to 'IfBlock's-ifelse :: [Field] -> ParseResult [Field]-ifelse [] = return []-ifelse (Section n "if"   cond thenpart-       :Section _ "else" as   elsepart:fs)-       | null cond     = syntaxError n "'if' with missing condition"-       | null thenpart = syntaxError n "'then' branch of 'if' is empty"-       | not (null as) = syntaxError n "'else' takes no arguments"-       | null elsepart = syntaxError n "'else' branch of 'if' is empty"-       | otherwise     = do tp  <- ifelse thenpart-                            ep  <- ifelse elsepart-                            fs' <- ifelse fs-                            return (IfBlock n cond tp ep:fs')-ifelse (Section n "if"   cond thenpart:fs)-       | null cond     = syntaxError n "'if' with missing condition"-       | null thenpart = syntaxError n "'then' branch of 'if' is empty"-       | otherwise     = do tp  <- ifelse thenpart-                            fs' <- ifelse fs-                            return (IfBlock n cond tp []:fs')-ifelse (Section n "else" _ _:_) = syntaxError n-                                  "stray 'else' with no preceding 'if'"-ifelse (Section n s a fs':fs) = do fs''  <- ifelse fs'-                                   fs''' <- ifelse fs-                                   return (Section n s a fs'' : fs''')-ifelse (f:fs) = do fs' <- ifelse fs-                   return (f : fs')----------------------------------------------------------------------------------parseFilePathQ :: ReadP r FilePath-parseFilePathQ = parseTokenQ-  -- removed until normalise is no longer broken, was:-  --   liftM normalise parseTokenQ---- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a--- because the "compat" version of ReadP isn't quite powerful enough.  In--- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a--- Hence the trick above to make 'lic' polymorphic.---- Different than the naive version. it turns out Read instance for String accepts--- the ['a', 'b'] syntax, which we do not want. In particular it messes--- up any token starting with [].-parseHaskellString :: ReadP r String-parseHaskellString =-  readS_to_P $-    Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0--parseTokenQ :: ReadP r String-parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')--parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas-               -> ReadP r [a]-parseSpaceList p = sepBy p skipSpaces---- This version avoid parse ambiguity for list element parsers--- that have multiple valid parses of prefixes.-parseOptCommaList :: ReadP r a -> ReadP r [a]-parseOptCommaList p = sepBy p localSep-  where-    -- The separator must not be empty or it introduces ambiguity-    localSep = (skipSpaces >> char ',' >> skipSpaces)-      +++ (satisfy isSpace >> skipSpaces)--readPToMaybe :: ReadP a a -> String -> Maybe a-readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str-                                     , all isSpace s ]
− Distribution/Deprecated/ReadP.hs 
@@ -1,480 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}--------------------------------------------------------------------------------- |------ Module      :  Distribution.Deprecated.ReadP--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ This is a library of parser combinators, originally written by Koen Claessen.--- It parses all alternatives in parallel, so it never keeps hold of--- the beginning of the input string, a common source of space leaks with--- other parsers.  The '(+++)' choice combinator is genuinely commutative;--- it makes no difference which branch is \"shorter\".------ See also Koen's paper /Parallel Parsing Processes/--- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).------ This version of ReadP has been locally hacked to make it H98, by--- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>------ The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by--- Mark Lentczner <mailto:mark@glyphic.com>--------------------------------------------------------------------------------module Distribution.Deprecated.ReadP-  (-  -- * The 'ReadP' type-  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus--  -- * Primitive operations-  get,        -- :: ReadP Char-  look,       -- :: ReadP String-  (+++),      -- :: ReadP a -> ReadP a -> ReadP a-  (<++),      -- :: ReadP a -> ReadP a -> ReadP a-  gather,     -- :: ReadP a -> ReadP (String, a)--  -- * Other operations-  pfail,      -- :: ReadP a-  eof,        -- :: ReadP ()-  satisfy,    -- :: (Char -> Bool) -> ReadP Char-  char,       -- :: Char -> ReadP Char-  string,     -- :: String -> ReadP String-  munch,      -- :: (Char -> Bool) -> ReadP String-  munch1,     -- :: (Char -> Bool) -> ReadP String-  skipSpaces, -- :: ReadP ()-  skipSpaces1,-- :: ReadP ()-  choice,     -- :: [ReadP a] -> ReadP a-  count,      -- :: Int -> ReadP a -> ReadP [a]-  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a-  option,     -- :: a -> ReadP a -> ReadP a-  optional,   -- :: ReadP a -> ReadP ()-  many,       -- :: ReadP a -> ReadP [a]-  many1,      -- :: ReadP a -> ReadP [a]-  skipMany,   -- :: ReadP a -> ReadP ()-  skipMany1,  -- :: ReadP a -> ReadP ()-  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]-  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]-  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]-  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]-  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a-  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a-  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]--  -- * Running a parser-  ReadS,      -- :: *; = String -> [(a,String)]-  readP_to_S, -- :: ReadP a -> ReadS a-  readS_to_P, -- :: ReadS a -> ReadP a-  readP_to_E,--  -- ** Internal-  Parser,-  )- where--import Prelude ()-import Distribution.Client.Compat.Prelude hiding (many, get)--import Control.Monad( replicateM, (>=>) )--import qualified Control.Monad.Fail as Fail--import           Distribution.CabalSpecVersion   (cabalSpecLatest)-import qualified Distribution.Compat.CharParsing as P-import qualified Distribution.Parsec       as P--import Distribution.ReadE (ReadE (..))--infixr 5 +++, <++---- ------------------------------------------------------------------------------ The P type--- is representation type -- should be kept abstract--data P s a-  = Get (s -> P s a)-  | Look ([s] -> P s a)-  | Fail-  | Result a (P s a)-  | Final [(a,[s])] -- invariant: list is non-empty!---- Monad, MonadPlus--instance Functor (P s) where-  fmap = liftM--instance Applicative (P s) where-  pure x = Result x Fail-  (<*>) = ap--instance Monad (P s) where-  return = pure--  (Get f)      >>= k = Get (f >=> k)-  (Look f)     >>= k = Look (f >=> k)-  Fail         >>= _ = Fail-  (Result x p) >>= k = k x `mplus` (p >>= k)-  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]--#if !(MIN_VERSION_base(4,9,0))-  fail _ = Fail-#elif !(MIN_VERSION_base(4,13,0))-  fail = Fail.fail-#endif--instance Fail.MonadFail (P s) where-  fail _ = Fail--instance Alternative (P s) where-      empty = mzero-      (<|>) = mplus--instance MonadPlus (P s) where-  mzero = Fail--  -- most common case: two gets are combined-  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)--  -- results are delivered as soon as possible-  Result x p `mplus` q          = Result x (p `mplus` q)-  p          `mplus` Result x q = Result x (p `mplus` q)--  -- fail disappears-  Fail       `mplus` p          = p-  p          `mplus` Fail       = p--  -- two finals are combined-  -- final + look becomes one look and one final (=optimization)-  -- final + sthg else becomes one look and one final-  Final r    `mplus` Final t    = Final (r ++ t)-  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))-  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))-  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))-  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))--  -- two looks are combined (=optimization)-  -- look + sthg else floats upwards-  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)-  Look f     `mplus` p          = Look (\s -> f s `mplus` p)-  p          `mplus` Look f     = Look (\s -> p `mplus` f s)---- ------------------------------------------------------------------------------ The ReadP type--newtype Parser r s a = R ((a -> P s r) -> P s r)-type ReadP r a = Parser r Char a---- Functor, Monad, MonadPlus--instance Functor (Parser r s) where-  fmap h (R f) = R (\k -> f (k . h))--instance Applicative (Parser r s) where-  pure x  = R (\k -> k x)-  (<*>) = ap--instance s ~ Char => Alternative (Parser r s) where-  empty = pfail-  (<|>) = (+++)--instance Monad (Parser r s) where-  return = pure-  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))--#if !(MIN_VERSION_base(4,9,0))-  fail _ = R (const Fail)-#elif !(MIN_VERSION_base(4,13,0))-  fail = Fail.fail-#endif--instance Fail.MonadFail (Parser r s) where-  fail _    = R (const Fail)--instance s ~ Char => MonadPlus (Parser r s) where-  mzero = pfail-  mplus = (+++)---- ------------------------------------------------------------------------------ Operations over P--final :: [(a,[s])] -> P s a--- Maintains invariant for Final constructor-final [] = Fail-final r  = Final r--run :: P c a -> ([c] -> [(a, [c])])-run (Get f)      (c:s) = run (f c) s-run (Look f)     s     = run (f s) s-run (Result x p) s     = (x,s) : run p s-run (Final r)    _     = r-run _            _     = []---- ------------------------------------------------------------------------------ Operations over ReadP--get :: ReadP r Char--- ^ Consumes and returns the next character.---   Fails if there is no input left.-get = R Get--look :: ReadP r String--- ^ Look-ahead: returns the part of the input that is left, without---   consuming it.-look = R Look--pfail :: ReadP r a--- ^ Always fails.-pfail = R (const Fail)--eof :: ReadP r ()--- ^ Succeeds iff we are at the end of input-eof = do { s <- look-         ; if null s then return ()-                     else pfail }--(+++) :: ReadP r a -> ReadP r a -> ReadP r a--- ^ Symmetric choice.-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)--(<++) :: ReadP a a -> ReadP r a -> ReadP r a--- ^ Local, exclusive, left-biased choice: If left parser---   locally produces any result at all, then right parser is---   not used.-R f <++ q =-  do s <- look-     probe (f return) s 0- where-  probe (Get f')       (c:s) n = probe (f' c) s (n+1 :: Int)-  probe (Look f')      s     n = probe (f' s) s n-  probe p@(Result _ _) _     n = discard n >> R (p >>=)-  probe (Final r)      _     _ = R (Final r >>=)-  probe _              _     _ = q--  discard 0 = return ()-  discard n  = get >> discard (n-1 :: Int)--gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)--- ^ Transforms a parser into one that does the same, but---   in addition returns the exact characters read.---   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument---   is built using any occurrences of readS_to_P.-gather (R m) =-  R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))- where-  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))-  gath _ Fail         = Fail-  gath l (Look f)     = Look (gath l . f)-  gath l (Result k p) = k (l []) `mplus` gath l p-  gath _ (Final _)    = error "do not use readS_to_P in gather!"---- ------------------------------------------------------------------------------ Derived operations--satisfy :: (Char -> Bool) -> ReadP r Char--- ^ Consumes and returns the next character, if it satisfies the---   specified predicate.-satisfy p = do c <- get; if p c then return c else pfail--char :: Char -> ReadP r Char--- ^ Parses and returns the specified character.-char c = satisfy (c ==)--string :: String -> ReadP r String--- ^ Parses and returns the specified string.-string this = do s <- look; scan this s- where-  scan []     _               = return this-  scan (x:xs) (y:ys) | x == y = get >> scan xs ys-  scan _      _               = pfail--munch :: (Char -> Bool) -> ReadP r String--- ^ Parses the first zero or more characters satisfying the predicate.-munch p =-  do s <- look-     scan s- where-  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)-  scan _            = do return ""--munch1 :: (Char -> Bool) -> ReadP r String--- ^ Parses the first one or more characters satisfying the predicate.-munch1 p =-  do c <- get-     if p c then do s <- munch p; return (c:s)-            else pfail--choice :: [ReadP r a] -> ReadP r a--- ^ Combines all parsers in the specified list.-choice []     = pfail-choice [p]    = p-choice (p:ps) = p +++ choice ps--skipSpaces :: ReadP r ()--- ^ Skips all whitespace.-skipSpaces =-  do s <- look-     skip s- where-  skip (c:s) | isSpace c = do _ <- get; skip s-  skip _                 = do return ()--skipSpaces1 :: ReadP r ()--- ^ Like 'skipSpaces' but succeeds only if there is at least one--- whitespace character to skip.-skipSpaces1 = satisfy isSpace >> skipSpaces--count :: Int -> ReadP r a -> ReadP r [a]--- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of---   results is returned.-count n p = replicateM n p--between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a--- ^ @ between open close p @ parses @open@, followed by @p@ and finally---   @close@. Only the value of @p@ is returned.-between open close p = do _ <- open-                          x <- p-                          _ <- close-                          return x--option :: a -> ReadP r a -> ReadP r a--- ^ @option x p@ will either parse @p@ or return @x@ without consuming---   any input.-option x p = p +++ return x--optional :: ReadP r a -> ReadP r ()--- ^ @optional p@ optionally parses @p@ and always returns @()@.-optional p = (p >> return ()) +++ return ()--many :: ReadP r a -> ReadP r [a]--- ^ Parses zero or more occurrences of the given parser.-many p = return [] +++ many1 p--many1 :: ReadP r a -> ReadP r [a]--- ^ Parses one or more occurrences of the given parser.-many1 p = liftM2 (:) p (many p)--skipMany :: ReadP r a -> ReadP r ()--- ^ Like 'many', but discards the result.-skipMany p = many p >> return ()--skipMany1 :: ReadP r a -> ReadP r ()--- ^ Like 'many1', but discards the result.-skipMany1 p = p >> skipMany p--sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy p sep = sepBy1 p sep +++ return []--sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.---   Returns a list of values returned by @p@.-sepBy1 p sep = liftM2 (:) p (many (sep >> p))--endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended---   by @sep@.-endBy p sep = many (do x <- p ; _ <- sep ; return x)--endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]--- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended---   by @sep@.-endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)--chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a--- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /right/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainr p op x = chainr1 p op +++ return x--chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a--- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.---   Returns a value produced by a /left/ associative application of all---   functions returned by @op@. If there are no occurrences of @p@, @x@ is---   returned.-chainl p op x = chainl1 p op +++ return x--chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a--- ^ Like 'chainr', but parses one or more occurrences of @p@.-chainr1 p op = scan-  where scan   = p >>= rest-        rest x = do f <- op-                    y <- scan-                    return (f x y)-                 +++ return x--chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a--- ^ Like 'chainl', but parses one or more occurrences of @p@.-chainl1 p op = p >>= rest-  where rest x = do f <- op-                    y <- p-                    rest (f x y)-                 +++ return x--manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]--- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@---   succeeds. Returns a list of values returned by @p@.-manyTill p end = scan-  where scan = (end >> return []) <++ (liftM2 (:) p scan)---- ------------------------------------------------------------------------------ Converting between ReadP and Read--readP_to_S :: ReadP a a -> ReadS a--- ^ Converts a parser into a Haskell ReadS-style function.---   This is the main way in which you can \"run\" a 'ReadP' parser:---   the expanded type is--- @ readP_to_S :: ReadP a -> String -> [(a,String)] @-readP_to_S (R f) = run (f return)--readS_to_P :: ReadS a -> ReadP r a--- ^ Converts a Haskell ReadS-style function into a parser.---   Warning: This introduces local backtracking in the resulting---   parser, and therefore a possible inefficiency.-readS_to_P r =-  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))------------------------------------------------------------------------------------ Instances----------------------------------------------------------------------------------instance t ~ Char => P.Parsing (Parser r t) where-  try        = id-  (<?>)      = const-  skipMany   = skipMany-  skipSome   = skipMany1-  unexpected = const pfail-  eof        = eof--  -- TODO: we would like to have <++ here-  notFollowedBy p = ((Just <$> p) +++ pure Nothing)-    >>= maybe (pure ()) (P.unexpected . show)--instance t ~ Char => P.CharParsing (Parser r t) where-  satisfy   = satisfy-  char      = char-  notChar c = satisfy (/= c)-  anyChar   = get-  string    = string--instance t ~ Char => P.CabalParsing (Parser r t) where-    parsecWarning _ _   = pure ()-    askCabalSpecVersion = pure cabalSpecLatest------------------------------------------------------------------------------------ ReadE----------------------------------------------------------------------------------readP_to_E :: (String -> String) -> ReadP a a -> ReadE a-readP_to_E err r =-    ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt-                         , all isSpace s ]-                    of [] -> Left (err txt)-                       (p:_) -> Right p
− Distribution/Deprecated/ViewAsFieldDescr.hs 
@@ -1,84 +0,0 @@-module Distribution.Deprecated.ViewAsFieldDescr (-    viewAsFieldDescr-    ) where--import Distribution.Client.Compat.Prelude hiding (get)-import Prelude ()--import qualified Data.List.NonEmpty as NE-import Distribution.ReadE          (parsecToReadE)-import Distribution.Simple.Command-import Text.PrettyPrint            (cat, comma, punctuate, text)-import Text.PrettyPrint            as PP (empty)--import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError)---- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >--- Choice > Opt) and consider only the first one.-viewAsFieldDescr :: OptionField a -> FieldDescr a-viewAsFieldDescr (OptionField _n []) =-  error "Distribution.command.viewAsFieldDescr: unexpected"-viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set--    where-      optDescr = head $ NE.sortBy cmp (d:|dd)--      cmp :: OptDescr a -> OptDescr a -> Ordering-      ReqArg{}    `cmp` ReqArg{}    = EQ-      ReqArg{}    `cmp` _           = GT-      BoolOpt{}   `cmp` ReqArg{}    = LT-      BoolOpt{}   `cmp` BoolOpt{}   = EQ-      BoolOpt{}   `cmp` _           = GT-      ChoiceOpt{} `cmp` ReqArg{}    = LT-      ChoiceOpt{} `cmp` BoolOpt{}   = LT-      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ-      ChoiceOpt{} `cmp` _           = GT-      OptArg{}    `cmp` OptArg{}    = EQ-      OptArg{}    `cmp` _           = LT----    get :: a -> Doc-      get t = case optDescr of-        ReqArg _ _ _ _ ppr ->-          (cat . punctuate comma . map text . ppr) t--        OptArg _ _ _ _ _ ppr ->-          case ppr t of []        -> PP.empty-                        (Nothing : _) -> text "True"-                        (Just a  : _) -> text a--        ChoiceOpt alts ->-          fromMaybe PP.empty $ listToMaybe-          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]--        BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t----    set :: LineNo -> String -> a -> ParseResult a-      set line val a =-        case optDescr of-          ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val-                                     -- We parse for a single value instead of a-                                     -- list, as one can't really implement-                                     -- parseList :: ReadE a -> ReadE [a] with-                                     -- the current ReadE definition-          ChoiceOpt{}             ->-            case getChoiceByLongFlag optDescr val of-              Just f -> return (f a)-              _      -> syntaxError line val--          BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val--          OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE val-                                     -- Optional arguments are parsed just like-                                     -- required arguments here; we don't-                                     -- provide a method to set an OptArg field-                                     -- to the default value.--getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a)-getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe-                                           [ set | (_,(_sf,lf:_), set, _) <- alts-                                                 , lf == val]--getChoiceByLongFlag _ _ =-  error "Distribution.command.getChoiceByLongFlag: expected a choice option"--
− Distribution/Solver/Compat/Prelude.hs 
@@ -1,19 +0,0 @@--- to suppress WARNING in "Distribution.Compat.Prelude.Internal"-{-# OPTIONS_GHC -fno-warn-deprecations #-}---- | This module does two things:------ * Acts as a compatibility layer, like @base-compat@.------ * Provides commonly used imports.------ This module is a superset of "Distribution.Compat.Prelude" (which--- this module re-exports)----module Distribution.Solver.Compat.Prelude-  ( module Distribution.Compat.Prelude.Internal-  , Prelude.IO-  ) where--import Prelude (IO)-import Distribution.Compat.Prelude.Internal hiding (IO)
− Distribution/Solver/Modular.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Distribution.Solver.Modular-         ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where---- Here, we try to map between the external cabal-install solver--- interface and the internal interface that the solver actually--- expects. There are a number of type conversions to perform: we--- have to convert the package indices to the uniform index used--- by the solver; we also have to convert the initial constraints;--- and finally, we have to convert back the resulting install--- plan.--import Prelude ()-import Distribution.Solver.Compat.Prelude--import qualified Data.Map as M-import Data.Set (isSubsetOf)-import Distribution.Compat.Graph-         ( IsNode(..) )-import Distribution.Compiler-         ( CompilerInfo )-import Distribution.Solver.Modular.Assignment-         ( Assignment, toCPs )-import Distribution.Solver.Modular.ConfiguredConversion-         ( convCP )-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.IndexConversion-         ( convPIs )-import Distribution.Solver.Modular.Log-         ( SolverFailure(..), displayLogMessages )-import Distribution.Solver.Modular.Package-         ( PN )-import Distribution.Solver.Modular.RetryLog-import Distribution.Solver.Modular.Solver-         ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )-import Distribution.Solver.Types.DependencyResolver-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.PkgConfigDb-         ( PkgConfigDb )-import Distribution.Solver.Types.Progress-import Distribution.Solver.Types.Variable-import Distribution.System-         ( Platform(..) )-import Distribution.Simple.Setup-         ( BooleanFlag(..) )-import Distribution.Simple.Utils-         ( ordNubBy )-import Distribution.Verbosity----- | Ties the two worlds together: classic cabal-install vs. the modular--- solver. Performs the necessary translations before and after.-modularResolver :: SolverConfig -> DependencyResolver loc-modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =-  fmap (uncurry postprocess) $ -- convert install plan-  solve' sc cinfo idx pkgConfigDB pprefs gcs pns-    where-      -- Indices have to be converted into solver-specific uniform index.-      idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx-      -- Constraints have to be converted into a finite map indexed by PN.-      gcs    = M.fromListWith (++) (map pair pcs)-        where-          pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])--      -- Results have to be converted into an install plan. 'convCP' removes-      -- package qualifiers, which means that linked packages become duplicates-      -- and can be removed.-      postprocess a rdm = ordNubBy nodeKey $-                          map (convCP iidx sidx) (toCPs a rdm)--      -- Helper function to extract the PN from a constraint.-      pcName :: PackageConstraint -> PN-      pcName (PackageConstraint scope _) = scopeToPackageName scope---- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display--- in the error case.------ When there is no solution, we produce the error message by rerunning the--- solver but making it prefer the goals from the final conflict set from the--- first run (or a subset of the final conflict set with--- --minimize-conflict-set). We also set the backjump limit to 0, so that the--- log stops at the first backjump and is relatively short. Preferring goals--- from the final conflict set increases the probability that the log to the--- first backjump contains package, flag, and stanza choices that are relevant--- to the final failure. The solver shouldn't need to choose any packages that--- aren't in the final conflict set. (For every variable in the final conflict--- set, the final conflict set should also contain the variable that introduced--- that variable. The solver can then follow that chain of variables in reverse--- order from the user target to the conflict.) However, it is possible that the--- conflict set contains unnecessary variables.------ Producing an error message when the solver reaches the backjump limit is more--- complicated. There is no final conflict set, so we create one for the minimal--- subtree containing the path that the solver took to the first backjump. This--- conflict set helps explain why the solver reached the backjump limit, because--- the first backjump contributes to reaching the backjump limit. Additionally,--- the solver is much more likely to be able to finish traversing this subtree--- before the backjump limit, since its size is linear (not exponential) in the--- number of goal choices. We create it by pruning all children after the first--- successful child under each node in the original tree, so that there is at--- most one valid choice at each level. Then we use the final conflict set from--- that run to generate an error message, as in the case where the solver found--- that there was no solution.------ Using the full log from a rerun of the solver ensures that the log is--- complete, i.e., it shows the whole chain of dependencies from the user--- targets to the conflicting packages.-solve' :: SolverConfig-       -> CompilerInfo-       -> Index-       -> PkgConfigDb-       -> (PN -> PackagePreferences)-       -> Map PN [LabeledPackageConstraint]-       -> Set PN-       -> Progress String String (Assignment, RevDepMap)-solve' sc cinfo idx pkgConfigDB pprefs gcs pns =-    toProgress $ retry (runSolver printFullLog sc) createErrorMsg-  where-    runSolver :: Bool -> SolverConfig-              -> RetryLog String SolverFailure (Assignment, RevDepMap)-    runSolver keepLog sc' =-        displayLogMessages keepLog $-        solve sc' cinfo idx pkgConfigDB pprefs gcs pns--    createErrorMsg :: SolverFailure-                   -> RetryLog String String (Assignment, RevDepMap)-    createErrorMsg failure@(ExhaustiveSearch cs cm) =-      if asBool $ minimizeConflictSet sc-      then continueWith ("Found no solution after exhaustively searching the "-                          ++ "dependency tree. Rerunning the dependency solver "-                          ++ "to minimize the conflict set ({"-                          ++ showConflictSet cs ++ "}).") $-           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $-               \case-                  ExhaustiveSearch cs' cm' ->-                      fromProgress $ Fail $-                          rerunSolverForErrorMsg cs'-                       ++ finalErrorMsg sc (ExhaustiveSearch cs' cm')-                  BackjumpLimitReached ->-                      fromProgress $ Fail $-                          "Reached backjump limit while trying to minimize the "-                       ++ "conflict set to create a better error message. "-                       ++ "Original error message:\n"-                       ++ rerunSolverForErrorMsg cs-                       ++ finalErrorMsg sc failure-      else fromProgress $ Fail $-           rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure-    createErrorMsg failure@BackjumpLimitReached     =-        continueWith-             ("Backjump limit reached. Rerunning dependency solver to generate "-              ++ "a final conflict set for the search tree containing the "-              ++ "first backjump.") $-        retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $-            \case-               ExhaustiveSearch cs _ ->-                   fromProgress $ Fail $-                   rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure-               BackjumpLimitReached  ->-                   -- This case is possible when the number of goals involved in-                   -- conflicts is greater than the backjump limit.-                   fromProgress $ Fail $ finalErrorMsg sc failure-                    ++ "Failed to generate a summarized dependency solver "-                    ++ "log due to low backjump limit."--    rerunSolverForErrorMsg :: ConflictSet -> String-    rerunSolverForErrorMsg cs =-      let sc' = sc {-                    goalOrder = Just goalOrder'-                  , maxBackjumps = Just 0-                  }--          -- Preferring goals from the conflict set takes precedence over the-          -- original goal order.-          goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)--      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))--    printFullLog = solverVerbosity sc >= verbose--    messages :: Progress step fail done -> [step]-    messages = foldProgress (:) (const []) (const [])---- | Try to remove variables from the given conflict set to create a minimal--- conflict set.------ Minimal means that no proper subset of the conflict set is also a conflict--- set, though there may be other possible conflict sets with fewer variables.--- This function minimizes the input by trying to remove one variable at a time.--- It only makes one pass over the variables, so it runs the solver at most N--- times when given a conflict set of size N. Only one pass is necessary,--- because every superset of a conflict set is also a conflict set, meaning that--- failing to remove variable X from a conflict set in one step means that X--- cannot be removed from any subset of that conflict set in a subsequent step.------ Example steps:------ Start with {A, B, C}.--- Try to remove A from {A, B, C} and fail.--- Try to remove B from {A, B, C} and succeed.--- Try to remove C from {A, C} and fail.--- Return {A, C}------ This function can fail for two reasons:------ 1. The solver can reach the backjump limit on any run. In this case the---    returned RetryLog ends with BackjumpLimitReached.---    TODO: Consider applying the backjump limit to all solver runs combined,---    instead of each individual run. For example, 10 runs with 10 backjumps---    each should count as 100 backjumps.--- 2. Since this function works by rerunning the solver, it is possible for the---    solver to add new unnecessary variables to the conflict set. This function---    discards the result from any run that adds new variables to the conflict---    set, but the end result may not be completely minimized.-tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)-                         -> SolverConfig-                         -> ConflictSet-                         -> ConflictMap-                         -> RetryLog String SolverFailure a-tryToMinimizeConflictSet runSolver sc cs cm =-    foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)-          (fromProgress $ Fail $ ExhaustiveSearch cs cm)-          (CS.toList cs)-  where-    -- This function runs the solver and makes it prefer goals in the following-    -- order:-    ---    -- 1. variables in 'smallestKnownCS', excluding 'v'-    -- 2. 'v'-    -- 3. all other variables-    ---    -- If 'v' is not necessary, then the solver will find that there is no-    -- solution before starting to solve for 'v', and the new final conflict set-    -- will be very likely to not contain 'v'. If 'v' is necessary, the solver-    -- will most likely need to try solving for 'v' before finding that there is-    -- no solution, and the new final conflict set will still contain 'v'.-    -- However, this method isn't perfect, because it is possible for the solver-    -- to add new unnecessary variables to the conflict set on any run. This-    -- function prevents the conflict set from growing by checking that the new-    -- conflict set is a subset of the old one and falling back to using the old-    -- conflict set when that check fails.-    tryToRemoveOneVar :: Var QPN-                      -> ConflictSet-                      -> ConflictMap-                      -> RetryLog String SolverFailure a-    tryToRemoveOneVar v smallestKnownCS smallestKnownCM-        -- Check whether v is still present, because it may have already been-        -- removed in a previous solver rerun.-      | not (v `CS.member` smallestKnownCS) =-          fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM-      | otherwise =-        continueWith ("Trying to remove variable " ++ varStr ++ " from the "-                      ++ "conflict set.") $-        retry (runSolver sc') $ \case-            err@(ExhaustiveSearch cs' _)-              | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->-                  let msg = if not $ CS.member v cs'-                            then "Successfully removed " ++ varStr ++ " from "-                                  ++ "the conflict set."-                            else "Failed to remove " ++ varStr ++ " from the "-                                  ++ "conflict set."-                  in -- Use the new conflict set, even if v wasn't removed,-                     -- because other variables may have been removed.-                     failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err-              | otherwise ->-                  failWith ("Failed to find a smaller conflict set. The new "-                             ++ "conflict set is not a subset of the previous "-                             ++ "conflict set: " ++ showCS cs') $-                  ExhaustiveSearch smallestKnownCS smallestKnownCM-            BackjumpLimitReached ->-                failWith ("Reached backjump limit while minimizing conflict set.")-                         BackjumpLimitReached-      where-        varStr = "\"" ++ showVar v ++ "\""-        showCS cs' = "{" ++ showConflictSet cs' ++ "}"--        sc' = sc { goalOrder = Just goalOrder' }--        goalOrder' =-            preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS)-         <> preferGoal v-         <> fromMaybe mempty (goalOrder sc)--    -- Like 'retry', except that it only applies the input function when the-    -- backjump limit has not been reached.-    retryNoSolution :: RetryLog step SolverFailure done-                    -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)-                    -> RetryLog step SolverFailure done-    retryNoSolution lg f = retry lg $ \case-        ExhaustiveSearch cs' cm' -> f cs' cm'-        BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)---- | Goal ordering that chooses goals contained in the conflict set before--- other goals.-preferGoalsFromConflictSet :: ConflictSet-                           -> Variable QPN -> Variable QPN -> Ordering-preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs---- | Goal ordering that chooses the given goal first.-preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering-preferGoal preferred = comparing $ \v -> toVar v /= preferred--toVar :: Variable QPN -> Var QPN-toVar (PackageVar qpn)    = P qpn-toVar (FlagVar    qpn fn) = F (FN qpn fn)-toVar (StanzaVar  qpn sn) = S (SN qpn sn)--finalErrorMsg :: SolverConfig -> SolverFailure -> String-finalErrorMsg sc failure =-    case failure of-      ExhaustiveSearch cs cm ->-          "After searching the rest of the dependency tree exhaustively, "-          ++ "these were the goals I've had most trouble fulfilling: "-          ++ showCS cm cs-          ++ flagSuggestion-        where-          showCS = if solverVerbosity sc > normal-                   then CS.showCSWithFrequency-                   else CS.showCSSortedByFrequency-          flagSuggestion =-              -- Don't suggest --minimize-conflict-set if the conflict set is-              -- already small, because it is unlikely to be reduced further.-              if CS.size cs > 3 && not (asBool (minimizeConflictSet sc))-              then "\nTry running with --minimize-conflict-set to improve the "-                    ++ "error message."-              else ""-      BackjumpLimitReached ->-          "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++-          "change with --max-backjumps or try to run with --reorder-goals).\n"-        where currlimit (Just n) = "currently " ++ show n ++ ", "-              currlimit Nothing  = ""
− Distribution/Solver/Modular/Assignment.hs 
@@ -1,95 +0,0 @@-module Distribution.Solver.Modular.Assignment-    ( Assignment(..)-    , PAssignment-    , FAssignment-    , SAssignment-    , toCPs-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (pi)--import qualified Data.Array as A-import qualified Data.List as L-import qualified Data.Map as M--import Data.Maybe (fromJust)--import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal--import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)-import qualified Distribution.Solver.Types.ComponentDeps as CD-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath--import Distribution.Solver.Modular.Configured-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.LabeledGraph-import Distribution.Solver.Modular.Package---- | A (partial) package assignment. Qualified package names--- are associated with instances.-type PAssignment    = Map QPN I--type FAssignment    = Map QFN Bool-type SAssignment    = Map QSN Bool---- | A (partial) assignment of variables.-data Assignment = A PAssignment FAssignment SAssignment-  deriving (Show, Eq)---- | Delivers an ordered list of fully configured packages.------ TODO: This function is (sort of) ok. However, there's an open bug--- w.r.t. unqualification. There might be several different instances--- of one package version chosen by the solver, which will lead to--- clashes.-toCPs :: Assignment -> RevDepMap -> [CP QPN]-toCPs (A pa fa sa) rdm =-  let-    -- get hold of the graph-    g   :: Graph Component-    vm  :: Vertex -> ((), QPN, [(Component, QPN)])-    cvm :: QPN -> Maybe Vertex-    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.-    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))-                                  (M.toList rdm))-    tg :: Graph Component-    tg = transposeG g-    -- Topsort the dependency graph, yielding a list of pkgs in the right order.-    -- The graph will still contain all the installed packages, and it might-    -- contain duplicates, because several variables might actually resolve to-    -- the same package in the presence of qualified package names.-    ps :: [PI QPN]-    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $-         topSort g-    -- Determine the flags per package, by walking over and regrouping the-    -- complete flag assignment by package.-    fapp :: Map QPN FlagAssignment-    fapp = M.fromListWith mappend $-           L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $-           M.toList $-           fa-    -- Stanzas per package.-    sapp :: Map QPN [OptionalStanza]-    sapp = M.fromListWith (++) $-           L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $-           M.toList $-           sa-    -- Dependencies per package.-    depp :: QPN -> [(Component, PI QPN)]-    depp qpn = let v :: Vertex-                   v   = fromJust (cvm qpn) -- TODO: why this is safe?-                   dvs :: [(Component, Vertex)]-                   dvs = tg A.! v-               in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs-    -- Translated to PackageDeps-    depp' :: QPN -> ComponentDeps [PI QPN]-    depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp-  in-    L.map (\ pi@(PI qpn _) -> CP pi-                                 (M.findWithDefault mempty qpn fapp)-                                 (M.findWithDefault mempty qpn sapp)-                                 (depp' qpn))-          ps
− Distribution/Solver/Modular/Builder.hs 
@@ -1,296 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.Builder (-    buildTree-  , splits -- for testing-  ) where---- Building the search tree.------ In this phase, we build a search tree that is too large, i.e, it contains--- invalid solutions. We keep track of the open goals at each point. We--- nondeterministically pick an open goal (via a goal choice node), create--- subtrees according to the index and the available solutions, and extend the--- set of open goals by superficially looking at the dependencies recorded in--- the index.------ For each goal, we keep track of all the *reasons* why it is being--- introduced. These are for debugging and error messages, mainly. A little bit--- of care has to be taken due to the way we treat flags. If a package has--- flag-guarded dependencies, we cannot introduce them immediately. Instead, we--- store the entire dependency.--import qualified Data.List as L-import qualified Data.Map as M-import qualified Data.Set as S-import Prelude--import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.PSQ as P-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.WeightedPSQ as W--import Distribution.Solver.Types.ComponentDeps-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Settings---- | All state needed to build and link the search tree. It has a type variable--- because the linking phase doesn't need to know about the state used to build--- the tree.-data Linker a = Linker {-  buildState   :: a,-  linkingState :: LinkingState-}---- | The state needed to build the search tree without creating any linked nodes.-data BuildState = BS {-  index :: Index,                   -- ^ information about packages and their dependencies-  rdeps :: RevDepMap,               -- ^ set of all package goals, completed and open, with reverse dependencies-  open  :: [OpenGoal],              -- ^ set of still open goals (flag and package goals)-  next  :: BuildType,               -- ^ kind of node to generate next-  qualifyOptions :: QualifyOptions  -- ^ qualification options-}---- | Map of available linking targets.-type LinkingState = M.Map (PN, I) [PackagePath]---- | Extend the set of open goals with the new goals listed.------ We also adjust the map of overall goals, and keep track of the--- reverse dependencies of each of the goals.-extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState-extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs-  where-    go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState-    go g o []                                             = s { rdeps = g, open = o }-    go g o ((Flagged fn@(FN qpn _) fInfo t f)  : ngs) =-        go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs-      -- Note: for 'Flagged' goals, we always insert, so later additions win.-      -- This is important, because in general, if a goal is inserted twice,-      -- the later addition will have better dependency information.-    go g o ((Stanza sn@(SN qpn _) t)           : ngs) =-        go g (StanzaGoal sn t (flagGR qpn) : o) ngs-    go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs)-      | qpn == qpn'       =-            -- We currently only add a self-dependency to the graph if it is-            -- between a package and its setup script. The edge creates a cycle-            -- and causes the solver to backtrack and choose a different-            -- instance for the setup script. We may need to track other-            -- self-dependencies once we implement component-based solving.-          case c of-            ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs-            _              -> go                                                    g  o ngs-      | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs-      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (PkgGoal qpn (DependencyGoal dr) : o) ngs-          -- code above is correct; insert/adjust have different arg order-    go g o ((Simple (LDep _dr (Ext _ext )) _)  : ngs) = go g o ngs-    go g o ((Simple (LDep _dr (Lang _lang))_)  : ngs) = go g o ngs-    go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs--    addIfAbsent :: Eq a => a -> [a] -> [a]-    addIfAbsent x xs = if x `elem` xs then xs else x : xs--    -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by-    -- its containing package.-    flagGR :: qpn -> GoalReason qpn-    flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)---- | Given the current scope, qualify all the package names in the given set of--- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->-                    BuildState -> BuildState-scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s-  where-    -- Qualify all package names-    qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps-    -- Introduce all package flags-    qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs-    -- Combine new package and flag goals-    gs     = qfdefs ++ qfdeps-    -- NOTE:-    ---    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially-    -- multiple times, both via the flag declaration and via dependencies.---- | 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 PInfo -- ^ build a tree for a concrete instance--build :: Linker BuildState -> Tree () QGoalReason-build = ana go-  where-    go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)-    go s = addLinking (linkingState s) $ addChildren (buildState s)--addChildren :: BuildState -> TreeF () QGoalReason BuildState---- If we have a choice between many goals, we just record the choice in--- the tree. We select each open goal in turn, and before we descend, remove--- it from the queue of open goals.-addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })-  | L.null gs = DoneF rdm ()-  | otherwise = GoalChoiceF rdm $ P.fromList-                                $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' }))-                                $ splits gs---- If we have already picked a goal, then the choice depends on the kind--- of goal.------ For a package, we look up the instances available in the global info,--- and then handle each instance in turn.-addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =-  case M.lookup pn idx of-    Nothing  -> FailF-                (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)-                UnknownPackage-    Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->-                                                       ([], POption i Nothing, bs { next = Instance qpn info }))-                                                     (M.toList pis)))-      -- TODO: data structure conversion is rather ugly here---- For a flag, we create only two subtrees, and we create them in the order--- that is indicated by the flag default.-addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =-  FChoiceF qfn rdm gr weak m b (W.fromList-    [([if b then 0 else 1], True,  (extendOpen qpn t bs) { next = Goals }),-     ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])-  where-    trivial = L.null t && L.null f-    weak = WeakOrTrivial $ unWeakOrTrivial w || trivial---- For a stanza, we also create only two subtrees. The order is initially--- False, True. This can be changed later by constraints (force enabling--- the stanza by replacing the False branch with failure) or preferences--- (try enabling the stanza if possible by moving the True branch first).--addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =-  SChoiceF qsn rdm gr trivial (W.fromList-    [([0], False,                                                                  bs  { next = Goals }),-     ([1], True,  (extendOpen qpn t bs) { next = Goals })])-  where-    trivial = WeakOrTrivial (L.null t)---- For a particular instance, we change the state: we update the scope,--- and furthermore we update the set of goals.------ TODO: We could inline this above.-addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) =-  addChildren ((scopedExtendOpen qpn fdeps fdefs bs)-         { next = Goals })--{--------------------------------------------------------------------------------  Add linking--------------------------------------------------------------------------------}---- | Introduce link nodes into the tree------ Linking is a phase that adapts package choice nodes and adds the option to--- link wherever appropriate: Package goals are called "related" if they are for--- the same instance of the same package (but have different prefixes). A link--- option is available in a package choice node whenever we can choose an--- instance that has already been chosen for a related goal at a higher position--- in the tree. We only create link options for related goals that are not--- themselves linked, because the choice to link to a linked goal is the same as--- the choice to link to the target of that goal's linking.------ The code here proceeds by maintaining a finite map recording choices that--- have been made at higher positions in the tree. For each pair of package name--- and instance, it stores the prefixes at which we have made a choice for this--- package instance. Whenever we make an unlinked choice, we extend the map.--- Whenever we find a choice, we look into the map in order to find out what--- link options we have to add.------ A separate tree traversal would be simpler. However, 'addLinking' creates--- linked nodes from existing unlinked nodes, which leads to sharing between the--- nodes. If we copied the nodes when they were full trees of type--- 'Tree () QGoalReason', then the sharing would cause a space leak during--- exploration of the tree. Instead, we only copy the 'BuildState', which is--- relatively small, while the tree is being constructed. See--- https://github.com/haskell/cabal/issues/2899-addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)--- The only nodes of interest are package nodes-addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =-  let linkedCs = fmap (\bs -> Linker bs ls) $-                 W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)-      unlinkedCs = W.mapWithKey goP cs-      allCs = unlinkedCs `W.union` linkedCs--      -- Recurse underneath package choices. Here we just need to make sure-      -- that we record the package choice so that it is available below-      goP :: POption -> a -> Linker a-      goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls-      goP _                   _  = alreadyLinked-  in PChoiceF qpn rdm gr allCs-addLinking ls t = fmap (\bs -> Linker bs ls) t--linkChoices :: forall a w . LinkingState-            -> QPN-            -> (w, POption, a)-            -> [(w, POption, a)]-linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =-    L.map aux (M.findWithDefault [] (pn, i) related)-  where-    aux :: PackagePath -> (w, POption, a)-    aux pp = (weight, POption i (Just pp), subtree)-linkChoices _ _ (_, POption _ (Just _), _) =-    alreadyLinked--alreadyLinked :: a-alreadyLinked = error "addLinking called on tree that already contains linked nodes"------------------------------------------------------------------------------------- | Interface to the tree builder. Just takes an index and a list of package names,--- and computes the initial state and then the tree from there.-buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason-buildTree idx (IndependentGoals ind) igs =-    build Linker {-        buildState = BS {-            index = idx-          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)-          , open  = L.map topLevelGoal qpns-          , next  = Goals-          , qualifyOptions = defaultQualifyOptions idx-          }-      , linkingState = M.empty-      }-  where-    topLevelGoal qpn = PkgGoal qpn UserGoal--    qpns | ind       = L.map makeIndependent igs-         | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs--{--------------------------------------------------------------------------------  Goals--------------------------------------------------------------------------------}---- | Information needed about a dependency before it is converted into a Goal.-data OpenGoal =-    FlagGoal   (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason-  | StanzaGoal (SN QPN)       (FlaggedDeps QPN)                   QGoalReason-  | PkgGoal    QPN                                                QGoalReason---- | Closes a goal, i.e., removes all the extraneous information that we--- need only during the build phase.-close :: OpenGoal -> Goal QPN-close (FlagGoal   qfn _ _ _ gr) = Goal (F qfn) gr-close (StanzaGoal qsn _     gr) = Goal (S qsn) gr-close (PkgGoal    qpn       gr) = Goal (P qpn) gr--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}---- | Pairs each element of a list with the list resulting from removal of that--- element from the original list.-splits :: [a] -> [(a, [a])]-splits = go id-  where-    go :: ([a] -> [a]) -> [a] -> [(a, [a])]-    go _ [] = []-    go f (x : xs) = (x, f xs) : go (f . (x :)) xs
− Distribution/Solver/Modular/Configured.hs 
@@ -1,13 +0,0 @@-module Distribution.Solver.Modular.Configured-    ( CP(..)-    ) where--import Distribution.PackageDescription (FlagAssignment)--import Distribution.Solver.Modular.Package-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import Distribution.Solver.Types.OptionalStanza---- | A configured package is a package instance together with--- a flag assignment and complete dependencies.-data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] (ComponentDeps [PI qpn])
− Distribution/Solver/Modular/ConfiguredConversion.hs 
@@ -1,72 +0,0 @@-module Distribution.Solver.Modular.ConfiguredConversion-    ( convCP-    ) where--import Data.Maybe-import Prelude hiding (pi)-import Data.Either (partitionEithers)--import Distribution.Package (UnitId, packageId)--import qualified Distribution.Simple.PackageIndex as SI--import Distribution.Solver.Modular.Configured-import Distribution.Solver.Modular.Package--import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)-import qualified Distribution.Solver.Types.PackageIndex as CI-import           Distribution.Solver.Types.PackagePath-import           Distribution.Solver.Types.ResolverPackage-import           Distribution.Solver.Types.SolverId-import           Distribution.Solver.Types.SolverPackage-import           Distribution.Solver.Types.InstSolverPackage-import           Distribution.Solver.Types.SourcePackage---- | Converts from the solver specific result @CP QPN@ into--- a 'ResolverPackage', which can then be converted into--- the install plan.-convCP :: SI.InstalledPackageIndex ->-          CI.PackageIndex (SourcePackage loc) ->-          CP QPN -> ResolverPackage loc-convCP iidx sidx (CP qpi fa es ds) =-  case convPI qpi of-    Left  pi -> PreExisting $-                  InstSolverPackage {-                    instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,-                    instSolverPkgLibDeps = fmap fst ds',-                    instSolverPkgExeDeps = fmap snd ds'-                  }-    Right pi -> Configured $-                  SolverPackage {-                      solverPkgSource = srcpkg,-                      solverPkgFlags = fa,-                      solverPkgStanzas = es,-                      solverPkgLibDeps = fmap fst ds',-                      solverPkgExeDeps = fmap snd ds'-                    }-      where-        srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi-  where-    ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})-    ds' = fmap (partitionEithers . map convConfId) ds--convPI :: PI QPN -> Either UnitId PackageId-convPI (PI _ (I _ (Inst pi))) = Left pi-convPI pi                     = Right (packageId (either id id (convConfId pi)))--convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}-convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =-    case loc of-        Inst pi -> Left (PreExistingId sourceId pi)-        _otherwise-          | QualExe _ pn' <- q-          -- NB: the dependencies of the executable are also-          -- qualified.  So the way to tell if this is an executable-          -- dependency is to make sure the qualifier is pointing-          -- at the actual thing.  Fortunately for us, I was-          -- silly and didn't allow arbitrarily nested build-tools-          -- dependencies, so a shallow check works.-          , pn == pn' -> Right (PlannedId sourceId)-          | otherwise    -> Left  (PlannedId sourceId)-  where-    sourceId    = PackageIdentifier pn v
− Distribution/Solver/Modular/ConflictSet.hs 
@@ -1,244 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif--- | Conflict sets------ Intended for double import------ > import Distribution.Solver.Modular.ConflictSet (ConflictSet)--- > import qualified Distribution.Solver.Modular.ConflictSet as CS-module Distribution.Solver.Modular.ConflictSet (-    ConflictSet -- opaque-  , Conflict(..)-  , ConflictMap-  , OrderedVersionRange(..)-#ifdef DEBUG_CONFLICT_SETS-  , conflictSetOrigin-#endif-  , showConflictSet-  , showCSSortedByFrequency-  , showCSWithFrequency-    -- Set-like operations-  , toSet-  , toList-  , union-  , unions-  , insert-  , delete-  , empty-  , singleton-  , singletonWithConflict-  , size-  , member-  , lookup-  , filter-  , fromList-  ) where--import Prelude hiding (lookup)-import Data.List (intercalate, sortBy)-import Data.Map (Map)-import Data.Set (Set)-import Data.Function (on)-import qualified Data.Map.Strict as M-import qualified Data.Set as S--#ifdef DEBUG_CONFLICT_SETS-import Data.Tree-import GHC.Stack-#endif--import Distribution.Solver.Modular.Var-import Distribution.Solver.Modular.Version-import Distribution.Solver.Types.PackagePath---- | The set of variables involved in a solver conflict, each paired with--- details about the conflict.-data ConflictSet = CS {-    -- | The set of variables involved in the conflict-    conflictSetToMap :: !(Map (Var QPN) (Set Conflict))--#ifdef DEBUG_CONFLICT_SETS-    -- | The origin of the conflict set-    ---    -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,-    -- we record the origin of every conflict set. For new conflict sets-    -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations-    -- that construct new conflict sets from existing conflict sets ('union',-    -- 'filter', ..)  we record the 'CallStack' to the call to the combinator-    -- as well as the 'CallStack's of the input conflict sets.-    ---    -- Requires @GHC >= 7.10@.-  , conflictSetOrigin :: Tree CallStack-#endif-  }-  deriving (Show)---- | More detailed information about how a conflict set variable caused a--- conflict. This information can be used to determine whether a second value--- for that variable would lead to the same conflict.------ TODO: Handle dependencies under flags or stanzas.-data Conflict =--    -- | The conflict set variable represents a package which depends on the-    -- specified problematic package. For example, the conflict set entry-    -- '(P x, GoalConflict y)' means that package x introduced package y, and y-    -- led to a conflict.-    GoalConflict QPN--    -- | The conflict set variable represents a package with a constraint that-    -- excluded the specified package and version. For example, the conflict set-    -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that-    -- package x's constraint on y excluded y-2.0.-  | VersionConstraintConflict QPN Ver--    -- | The conflict set variable represents a package that was excluded by a-    -- constraint from the specified package. For example, the conflict set-    -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))'-    -- means that package y's constraint 'x >= 2.0' excluded some version of x.-  | VersionConflict QPN OrderedVersionRange--    -- | Any other conflict.-  | OtherConflict-  deriving (Eq, Ord, Show)---- | Version range with an 'Ord' instance.-newtype OrderedVersionRange = OrderedVersionRange VR-  deriving (Eq, Show)---- TODO: Avoid converting the version ranges to strings.-instance Ord OrderedVersionRange where-  compare = compare `on` show--instance Eq ConflictSet where-  (==) = (==) `on` conflictSetToMap--instance Ord ConflictSet where-  compare = compare `on` conflictSetToMap--showConflictSet :: ConflictSet -> String-showConflictSet = intercalate ", " . map showVar . toList--showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String-showCSSortedByFrequency = showCS False--showCSWithFrequency :: ConflictMap -> ConflictSet -> String-showCSWithFrequency = showCS True--showCS :: Bool -> ConflictMap -> ConflictSet -> String-showCS showCount cm =-    intercalate ", " . map showWithFrequency . indexByFrequency-  where-    indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList-    showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of-      Just frequency-        | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")"-      _             -> showVar conflict--{--------------------------------------------------------------------------------  Set-like operations--------------------------------------------------------------------------------}--toSet :: ConflictSet -> Set (Var QPN)-toSet = M.keysSet . conflictSetToMap--toList :: ConflictSet -> [Var QPN]-toList = M.keys . conflictSetToMap--union ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  ConflictSet -> ConflictSet -> ConflictSet-union cs cs' = CS {-      conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs')-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])-#endif-    }--unions ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  [ConflictSet] -> ConflictSet-unions css = CS {-      conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc (map conflictSetOrigin css)-#endif-    }--insert ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> ConflictSet -> ConflictSet-insert var cs = CS {-      conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]-#endif-    }--delete :: Var QPN -> ConflictSet -> ConflictSet-delete var cs = CS {-      conflictSetToMap = M.delete var (conflictSetToMap cs)-    }--empty ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  ConflictSet-empty = CS {-      conflictSetToMap = M.empty-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif-    }--singleton ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> ConflictSet-singleton var = singletonWithConflict var OtherConflict--singletonWithConflict ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> Conflict -> ConflictSet-singletonWithConflict var conflict = CS {-      conflictSetToMap = M.singleton var (S.singleton conflict)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif-    }--size :: ConflictSet -> Int-size = M.size . conflictSetToMap--member :: Var QPN -> ConflictSet -> Bool-member var = M.member var . conflictSetToMap--lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict)-lookup var = M.lookup var . conflictSetToMap--fromList ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  [Var QPN] -> ConflictSet-fromList vars = CS {-      conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars]-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif-    }--type ConflictMap = Map (Var QPN) Int-
− Distribution/Solver/Modular/Cycles.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Distribution.Solver.Modular.Cycles (-    detectCyclesPhase-  ) where--import Prelude hiding (cycle)-import qualified Data.Map as M-import qualified Data.Set as S--import qualified Distribution.Compat.Graph as G-import Distribution.Simple.Utils (ordNub)-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Types.ComponentDeps (Component)-import Distribution.Solver.Types.PackagePath---- | Find and reject any nodes with cyclic dependencies-detectCyclesPhase :: Tree d c -> Tree d c-detectCyclesPhase = cata go-  where-    -- Only check children of choice nodes.-    go :: TreeF d c (Tree d c) -> Tree d c-    go (PChoiceF qpn rdm gr                         cs) =-        PChoice qpn rdm gr     $ fmap (checkChild qpn)   cs-    go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) =-        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs-    go (SChoiceF qsn@(SN qpn _) rdm gr w     cs) =-        SChoice qsn rdm gr w   $ fmap (checkChild qpn)   cs-    go x                                                = inn x--    checkChild :: QPN -> Tree d c -> Tree d c-    checkChild qpn x@(PChoice _  rdm _       _) = failIfCycle qpn rdm x-    checkChild qpn x@(FChoice _  rdm _ _ _ _ _) = failIfCycle qpn rdm x-    checkChild qpn x@(SChoice _  rdm _ _     _) = failIfCycle qpn rdm x-    checkChild qpn x@(GoalChoice rdm         _) = failIfCycle qpn rdm x-    checkChild _   x@(Fail _ _)                 = x-    checkChild qpn x@(Done       rdm _)         = failIfCycle qpn rdm x--    failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c-    failIfCycle qpn rdm x =-      case findCycles qpn rdm of-        Nothing     -> x-        Just relSet -> Fail relSet CyclicDependencies---- | Given the reverse dependency map from a node in the tree, check--- if the solution is cyclic. If it is, return the conflict set containing--- all decisions that could potentially break the cycle.------ TODO: The conflict set should also contain flag and stanza variables.-findCycles :: QPN -> RevDepMap -> Maybe ConflictSet-findCycles pkg rdm =-    -- This function has two parts: a faster cycle check that is called at every-    -- step and a slower calculation of the conflict set.-    ---    -- 'hasCycle' checks for cycles incrementally by only looking for cycles-    -- containing the current package, 'pkg'. It searches for cycles in the-    -- 'RevDepMap', which is the data structure used to store reverse-    -- dependencies in the search tree. We store the reverse dependencies in a-    -- map, because Data.Map is smaller and/or has better sharing than-    -- Distribution.Compat.Graph.-    ---    -- If there is a cycle, we call G.cycles to find a strongly connected-    -- component. Then we choose one cycle from the component to use for the-    -- conflict set. Choosing only one cycle can lead to a smaller conflict set,-    -- such as when a choice to enable testing introduces many cycles at once.-    -- In that case, all cycles contain the current package and are in one large-    -- strongly connected component.-    ---    if hasCycle-    then let scc :: G.Graph RevDepMapNode-             scc = case G.cycles $ revDepMapToGraph rdm of-                     []    -> findCyclesError "cannot find a strongly connected component"-                     c : _ -> G.fromDistinctList c--             next :: QPN -> QPN-             next p = case G.neighbors scc p of-                        Just (n : _) -> G.nodeKey n-                        _            -> findCyclesError "cannot find next node in the cycle"--             -- This function also assumes that all cycles contain 'pkg'.-             oneCycle :: [QPN]-             oneCycle = case iterate next pkg of-                          []     -> findCyclesError "empty cycle"-                          x : xs -> x : takeWhile (/= x) xs-         in Just $ CS.fromList $ map P oneCycle-    else Nothing-  where-    hasCycle :: Bool-    hasCycle = pkg `S.member` closure (neighbors pkg)--    closure :: [QPN] -> S.Set QPN-    closure = foldl go S.empty-      where-        go :: S.Set QPN -> QPN -> S.Set QPN-        go s x =-            if x `S.member` s-            then s-            else foldl go (S.insert x s) $ neighbors x--    neighbors :: QPN -> [QPN]-    neighbors x = case x `M.lookup` rdm of-                    Nothing -> findCyclesError "cannot find node"-                    Just xs -> map snd xs--    findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++)--data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)]--instance G.IsNode RevDepMapNode where-  type Key RevDepMapNode = QPN-  nodeKey (RevDepMapNode qpn _) = qpn-  nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns--revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode-revDepMapToGraph rdm = G.fromDistinctList-                       [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]
− Distribution/Solver/Modular/Dependency.hs 
@@ -1,358 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}-module Distribution.Solver.Modular.Dependency (-    -- * Variables-    Var(..)-  , showVar-  , varPN-    -- * Conflict sets-  , ConflictSet-  , ConflictMap-  , CS.showConflictSet-    -- * Constrained instances-  , CI(..)-    -- * Flagged dependencies-  , FlaggedDeps-  , FlaggedDep(..)-  , LDep(..)-  , Dep(..)-  , PkgComponent(..)-  , ExposedComponent(..)-  , DependencyReason(..)-  , showDependencyReason-  , flattenFlaggedDeps-  , QualifyOptions(..)-  , qualifyDeps-  , unqualifyDeps-    -- * Reverse dependency map-  , RevDepMap-    -- * Goals-  , Goal(..)-  , GoalReason(..)-  , QGoalReason-  , goalToVar-  , varToConflictSet-  , goalReasonToConflictSet-  , goalReasonToConflictSetWithConflict-  , dependencyReasonToConflictSet-  , dependencyReasonToConflictSetWithVersionConstraintConflict-  , dependencyReasonToConflictSetWithVersionConflict-  ) where--import Prelude ()-import qualified Data.Map as M-import qualified Data.Set as S-import Distribution.Solver.Compat.Prelude hiding (pi)--import Language.Haskell.Extension (Extension(..), Language(..))--import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Var-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.ConflictSet as CS--import Distribution.Solver.Types.ComponentDeps (Component(..))-import Distribution.Solver.Types.PackagePath-import Distribution.Types.LibraryName-import Distribution.Types.PkgconfigVersionRange-import Distribution.Types.UnqualComponentName--{--------------------------------------------------------------------------------  Constrained instances--------------------------------------------------------------------------------}---- | Constrained instance. It represents the allowed instances for a package,--- which can be either a fixed instance or a version range.-data CI = Fixed I | Constrained VR-  deriving (Eq, Show)--{--------------------------------------------------------------------------------  Flagged dependencies--------------------------------------------------------------------------------}---- | Flagged dependencies------ 'FlaggedDeps' is the modular solver's view of a packages dependencies:--- rather than having the dependencies indexed by component, each dependency--- defines what component it is in.------ Note that each dependency is associated with a Component. We must know what--- component the dependencies belong to, or else we won't be able to construct--- fine-grained reverse dependencies.-type FlaggedDeps qpn = [FlaggedDep qpn]---- | Flagged dependencies can either be plain dependency constraints,--- or flag-dependent dependency trees.-data FlaggedDep qpn =-    -- | Dependencies which are conditional on a flag choice.-    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)-    -- | Dependencies which are conditional on whether or not a stanza-    -- (e.g., a test suite or benchmark) is enabled.-  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)-    -- | Dependencies which are always enabled, for the component 'comp'.-  | Simple (LDep qpn) Component---- | Conversatively flatten out flagged dependencies------ NOTE: We do not filter out duplicates.-flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)]-flattenFlaggedDeps = concatMap aux-  where-    aux :: FlaggedDep qpn -> [(LDep qpn, Component)]-    aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f-    aux (Stanza  _   t)   = flattenFlaggedDeps t-    aux (Simple d c)      = [(d, c)]--type TrueFlaggedDeps  qpn = FlaggedDeps qpn-type FalseFlaggedDeps qpn = FlaggedDeps qpn---- | A 'Dep' labeled with the reason it was introduced.------ 'LDep' intentionally has no 'Functor' instance because the type variable--- is used both to record the dependencies as well as who's doing the--- depending; having a 'Functor' instance makes bugs where we don't distinguish--- these two far too likely. (By rights 'LDep' ought to have two type variables.)-data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)---- | A dependency (constraint) associates a package name with a constrained--- instance. It can also represent other types of dependencies, such as--- dependencies on language extensions.-data Dep qpn = Dep (PkgComponent qpn) CI  -- ^ dependency on a package component-             | Ext Extension              -- ^ dependency on a language extension-             | Lang Language              -- ^ dependency on a language version-             | Pkg PkgconfigName PkgconfigVersionRange  -- ^ dependency on a pkg-config package-  deriving Functor---- | An exposed component within a package. This type is used to represent--- build-depends and build-tool-depends dependencies.-data PkgComponent qpn = PkgComponent qpn ExposedComponent-  deriving (Eq, Ord, Functor, Show)---- | A component that can be depended upon by another package, i.e., a library--- or an executable.-data ExposedComponent =-    ExposedLib LibraryName-  | ExposedExe UnqualComponentName-  deriving (Eq, Ord, Show)---- | The reason that a dependency is active. It identifies the package and any--- flag and stanza choices that introduced the dependency. It contains--- everything needed for creating ConflictSets or describing conflicts in solver--- log messages.-data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)-  deriving (Functor, Eq, Show)---- | Print the reason that a dependency was introduced.-showDependencyReason :: DependencyReason QPN -> String-showDependencyReason (DependencyReason qpn flags stanzas) =-    intercalate " " $-        showQPN qpn-      : map (uncurry showFlagValue) (M.toList flags)-     ++ map (\s -> showSBool s True) (S.toList stanzas)---- | Options for goal qualification (used in 'qualifyDeps')------ See also 'defaultQualifyOptions'-data QualifyOptions = QO {-    -- | Do we have a version of base relying on another version of base?-    qoBaseShim :: Bool--    -- Should dependencies of the setup script be treated as independent?-  , qoSetupIndependent :: Bool-  }-  deriving Show---- | Apply built-in rules for package qualifiers------ Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions',--- it is important that these 'QualifyOptions' are _static_. Qualification--- does NOT depend on flag assignment; in other words, it behaves the same no--- matter which choices the solver makes (modulo the global 'QualifyOptions');--- we rely on this in 'linkDeps' (see comment there).------ NOTE: It's the _dependencies_ of a package that may or may not be independent--- from the package itself. Package flag choices must of course be consistent.-qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN-qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go-  where-    go :: FlaggedDeps PN -> FlaggedDeps QPN-    go = map go1--    go1 :: FlaggedDep PN -> FlaggedDep QPN-    go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)-    go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)-    go1 (Simple dep comp)    = Simple (goLDep dep comp) comp--    -- Suppose package B has a setup dependency on package A.-    -- This will be recorded as something like-    ---    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion))-    ---    -- Observe that when we qualify this dependency, we need to turn that-    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier-    -- to the DependencyReason.-    goLDep :: LDep PN -> Component -> LDep QPN-    goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp)--    goD :: Dep PN -> Component -> Dep QPN-    goD (Ext  ext)    _    = Ext  ext-    goD (Lang lang)   _    = Lang lang-    goD (Pkg pkn vr)  _    = Pkg pkn vr-    goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =-        Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci-    goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp-      | qBase qpn   = Dep (Q (PackagePath ns (QualBase  pn)) <$> dep) ci-      | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci-      | otherwise   = Dep (Q (PackagePath ns inheritedQ    ) <$> dep) ci--    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then-    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup-    -- dependency on R. We do not do this for the base qualifier however.-    ---    -- The inherited qualifier is only used for regular dependencies; for setup-    -- and base deppendencies we override the existing qualifier. See #3160 for-    -- a detailed discussion.-    inheritedQ :: Qualifier-    inheritedQ = case q of-                   QualSetup _  -> q-                   QualExe _ _  -> q-                   QualToplevel -> q-                   QualBase _   -> QualToplevel--    -- Should we qualify this goal with the 'Base' package path?-    qBase :: PN -> Bool-    qBase dep = qoBaseShim && unPackageName dep == "base"--    -- Should we qualify this goal with the 'Setup' package path?-    qSetup :: Component -> Bool-    qSetup comp = qoSetupIndependent && comp == ComponentSetup---- | Remove qualifiers from set of dependencies------ This is used during link validation: when we link package @Q.A@ to @Q'.A@,--- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute--- what to link these dependencies to, we need to requalify @Q.B@ to become--- @Q'.B@; we do this by first removing all qualifiers and then calling--- 'qualifyDeps' again.-unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN-unqualifyDeps = go-  where-    go :: FlaggedDeps QPN -> FlaggedDeps PN-    go = map go1--    go1 :: FlaggedDep QPN -> FlaggedDep PN-    go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)-    go1 (Stanza  sn     t)   = Stanza  (fmap unq sn)     (go t)-    go1 (Simple dep comp)    = Simple (goLDep dep) comp--    goLDep :: LDep QPN -> LDep PN-    goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep)--    unq :: QPN -> PN-    unq (Q _ pn) = pn--{--------------------------------------------------------------------------------  Reverse dependency map--------------------------------------------------------------------------------}---- | A map containing reverse dependencies between qualified--- package names.-type RevDepMap = Map QPN [(Component, QPN)]--{--------------------------------------------------------------------------------  Goals--------------------------------------------------------------------------------}---- | A goal is just a solver variable paired with a reason.--- The reason is only used for tracing.-data Goal qpn = Goal (Var qpn) (GoalReason qpn)-  deriving (Eq, Show, Functor)---- | Reason why a goal is being added to a goal set.-data GoalReason qpn =-    UserGoal                              -- introduced by a build target-  | DependencyGoal (DependencyReason qpn) -- introduced by a package-  deriving (Eq, Show, Functor)--type QGoalReason = GoalReason QPN--goalToVar :: Goal a -> Var a-goalToVar (Goal v _) = v---- | Compute a singleton conflict set from a 'Var'-varToConflictSet :: Var QPN -> ConflictSet-varToConflictSet = CS.singleton---- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal--- leads to a conflict.-goalReasonToConflictSet :: GoalReason QPN -> ConflictSet-goalReasonToConflictSet UserGoal            = CS.empty-goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr---- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the--- conflict occurred, namely the conflict set variables caused a conflict by--- introducing the given package goal. See the documentation for 'GoalConflict'.------ This function currently only specifies the reason for the conflict in the--- simple case where the 'GoalReason' does not involve any flags or stanzas.--- Otherwise, it falls back to calling 'goalReasonToConflictSet'.-goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet-goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas))-  | M.null flags && S.null stanzas =-      CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal-goalReasonToConflictSetWithConflict _    gr = goalReasonToConflictSet gr---- | This function returns the solver variables responsible for the dependency.--- It drops the values chosen for flag and stanza variables, which are only--- needed for log messages.-dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet-dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) =-    CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)-  where-    -- Filter out any flags that introduced the dependency with both values.-    -- They don't need to be included in the conflict set, because changing the-    -- flag value can't remove the dependency.-    flagVars :: [Var QPN]-    flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth]--    stanzaToVar :: Stanza -> Var QPN-    stanzaToVar = S . SN qpn---- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the--- conflict occurred because the conflict set variables introduced a problematic--- version constraint. See the documentation for 'VersionConstraintConflict'.------ This function currently only specifies the reason for the conflict in the--- simple case where the 'DependencyReason' does not involve any flags or--- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.-dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN-                                                           -> Ver-                                                           -> DependencyReason QPN-                                                           -> ConflictSet-dependencyReasonToConflictSetWithVersionConstraintConflict-    dependency excludedVersion dr@(DependencyReason qpn flags stanzas)-  | M.null flags && S.null stanzas =-    CS.singletonWithConflict (P qpn) $-    CS.VersionConstraintConflict dependency excludedVersion-  | otherwise = dependencyReasonToConflictSet dr---- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the--- conflict occurred because the conflict set variables introduced a version of--- a package that was excluded by a version constraint. See the documentation--- for 'VersionConflict'.------ This function currently only specifies the reason for the conflict in the--- simple case where the 'DependencyReason' does not involve any flags or--- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.-dependencyReasonToConflictSetWithVersionConflict :: QPN-                                                 -> CS.OrderedVersionRange-                                                 -> DependencyReason QPN-                                                 -> ConflictSet-dependencyReasonToConflictSetWithVersionConflict-    pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas)-  | M.null flags && S.null stanzas =-    CS.singletonWithConflict (P qpn) $-    CS.VersionConflict pkgWithVersionConstraint constraint-  | otherwise = dependencyReasonToConflictSet dr
− Distribution/Solver/Modular/Explore.hs 
@@ -1,367 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.Explore (backjumpAndExplore) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Distribution.Solver.Types.Progress as P--import qualified Data.List as L (foldl')-import qualified Data.Map.Strict as M-import qualified Data.Set as S--import Distribution.Simple.Setup (asBool)--import Distribution.Solver.Modular.Assignment-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Log-import Distribution.Solver.Modular.Message-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.PSQ as P-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.RetryLog-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.WeightedPSQ as W-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Settings-         (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..))-import Distribution.Types.VersionRange (anyVersion)---- | This function takes the variable we're currently considering, a--- last conflict set and a list of children's logs. Each log yields--- either a solution or a conflict set. The result is a combined log for--- the parent node that has explored a prefix of the children.------ We can stop traversing the children's logs if we find an individual--- conflict set that does not contain the current variable. In this--- case, we can just lift the conflict set to the current level,--- because the current level cannot possibly have contributed to this--- conflict, so no other choice at the current level would avoid the--- conflict.------ If any of the children might contain a successful solution, we can--- return it immediately. If all children contain conflict sets, we can--- take the union as the combined conflict set.------ The last conflict set corresponds to the justification that we--- have to choose this goal at all. There is a reason why we have--- introduced the goal in the first place, and this reason is in conflict--- with the (virtual) option not to choose anything for the current--- variable. See also the comments for 'avoidSet'.------ We can also skip a child if it does not resolve any of the conflicts paired--- with the current variable in the previous child's conflict set. 'backjump'--- takes a function to determine whether a child can be skipped. If the child--- can be skipped, the function returns a new conflict set to be merged with the--- previous conflict set.----backjump :: forall w k a . Maybe Int-         -> EnableBackjumping-         -> FineGrainedConflicts--         -> (k -> S.Set CS.Conflict -> Maybe ConflictSet)-            -- ^ Function that determines whether the given choice could resolve-            --   the given conflict. It indicates false by returning 'Just',-            --   with the new conflicts to be added to the conflict set.--         -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a)-            -- ^ Function that logs the given choice that was skipped.--         -> Var QPN -- ^ The current variable.--         -> ConflictSet -- ^ Conflict set representing the reason that the goal-                        --   was introduced.--         -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a)-            -- ^ List of children's logs.--         -> ExploreState -> ConflictSetLog a-backjump mbj enableBj fineGrainedConflicts couldResolveConflicts-         logSkippedChoice var lastCS xs =-    foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing-  where-    combine :: (k, ExploreState -> ConflictSetLog a)-            -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a)-            ->  ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a-    combine (k, x) f csAcc mPreviousCS es =-        case (asBool fineGrainedConflicts, mPreviousCS) of-          (True, Just previousCS) ->-              case CS.lookup var previousCS of-                Just conflicts ->-                  case couldResolveConflicts k conflicts of-                    Nothing           -> retryNoSolution (x es) next-                    Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts)-                _              -> skipChoice previousCS-          _                       -> retryNoSolution (x es) next-      where-        next :: ConflictSet -> ExploreState -> ConflictSetLog a-        next !cs es' = if asBool enableBj && not (var `CS.member` cs)-                       then skipLoggingBackjump cs es'-                       else f (csAcc `CS.union` cs) (Just cs) es'--        -- This function is for skipping the choice when it cannot resolve any-        -- of the previous conflicts.-        skipChoice :: ConflictSet -> ConflictSetLog a-        skipChoice newCS =-            retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' ->-                f (csAcc `CS.union` cs') (Just cs') $--                -- Update the conflict map with the conflict set, to make up for-                -- skipping the whole subtree.-                es' { esConflictMap = updateCM cs' (esConflictMap es') }--    -- This function represents the option to not choose a value for this goal.-    avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a-    avoidGoal cs _mPreviousCS !es =-        logBackjump mbj (cs `CS.union` lastCS) $--        -- Use 'lastCS' below instead of 'cs' since we do not want to-        -- double-count the additionally accumulated conflicts.-        es { esConflictMap = updateCM lastCS (esConflictMap es) }--    -- The solver does not count or log backjumps at levels where the conflict-    -- set does not contain the current variable. Otherwise, there would be many-    -- consecutive log messages about backjumping with the same conflict set.-    skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a-    skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es)---- | Creates a failing ConflictSetLog representing a backjump. It inserts a--- "backjumping" message, checks whether the backjump limit has been reached,--- and increments the backjump count.-logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a-logBackjump mbj cs es =-    failWith (Failure cs Backjump) $-        if reachedBjLimit (esBackjumps es)-        then BackjumpLimit-        else NoSolution cs es { esBackjumps = esBackjumps es + 1 }-  where-    reachedBjLimit = case mbj of-                       Nothing    -> const False-                       Just limit -> (>= limit)---- | Like 'retry', except that it only applies the input function when the--- backjump limit has not been reached.-retryNoSolution :: ConflictSetLog a-                -> (ConflictSet -> ExploreState -> ConflictSetLog a)-                -> ConflictSetLog a-retryNoSolution lg f = retry lg $ \case-    BackjumpLimit    -> fromProgress (P.Fail BackjumpLimit)-    NoSolution cs es -> f cs es---- | The state that is read and written while exploring the search tree.-data ExploreState = ES {-    esConflictMap :: !ConflictMap-  , esBackjumps   :: !Int-  }--data IntermediateFailure =-    NoSolution ConflictSet ExploreState-  | BackjumpLimit--type ConflictSetLog = RetryLog Message IntermediateFailure--getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)-getBestGoal cm =-  P.maximumBy-    ( flip (M.findWithDefault 0) cm-    . (\ (Goal v _) -> v)-    )--getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a)-getFirstGoal ts =-  P.casePSQ ts-    (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error-    (\ k v _xs -> (k, v))  -- commit to the first goal choice--updateCM :: ConflictSet -> ConflictMap -> ConflictMap-updateCM cs cm =-  L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs)---- | Record complete assignments on 'Done' nodes.-assign :: Tree d c -> Tree Assignment c-assign tree = cata go tree $ A M.empty M.empty M.empty-  where-    go :: TreeF d c (Assignment -> Tree Assignment c)-                 -> (Assignment -> Tree Assignment c)-    go (FailF c fr)            _                  = Fail c fr-    go (DoneF rdm _)           a                  = Done rdm a-    go (PChoiceF qpn rdm y       ts) (A pa fa sa) = PChoice qpn rdm y       $ W.mapWithKey f ts-        where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)-    go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts-        where f k             r = r (A pa (M.insert qfn k fa) sa)-    go (SChoiceF qsn rdm y t     ts) (A pa fa sa) = SChoice qsn rdm y t     $ W.mapWithKey f ts-        where f k             r = r (A pa fa (M.insert qsn k sa))-    go (GoalChoiceF  rdm         ts) a            = GoalChoice  rdm         $ fmap ($ a) ts---- | A tree traversal that simultaneously propagates conflict sets up--- the tree from the leaves and creates a log.-exploreLog :: Maybe Int-           -> EnableBackjumping-           -> FineGrainedConflicts-           -> CountConflicts-           -> Index-           -> Tree Assignment QGoalReason-           -> ConflictSetLog (Assignment, RevDepMap)-exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t =-    para go t initES-  where-    getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)-    getBestGoal'-      | asBool countConflicts = \ ts cm -> getBestGoal cm ts-      | otherwise             = \ ts _  -> getFirstGoal ts--    go :: TreeF Assignment QGoalReason-                (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason)-                                    -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap))-    go (FailF c fr)                            = \ !es ->-        let es' = es { esConflictMap = updateCM c (esConflictMap es) }-        in failWith (Failure c fr) (NoSolution c es')-    go (DoneF rdm a)                           = \ _   -> succeedWith Success (a, rdm)-    go (PChoiceF qpn _ gr       ts)            =-      backjump mbj enableBj fineGrainedConflicts-               (couldResolveConflicts qpn)-               (logSkippedPackage qpn)-               (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,-               W.mapWithKey                    -- when descending ...-                 (\ k r es -> tryWith (TryP qpn k) (r es))-                 (fmap fst ts)-    go (FChoiceF qfn _ gr _ _ _ ts)            =-      backjump mbj enableBj fineGrainedConflicts-               (\_ _ -> Nothing)-               (const logSkippedChoiceSimple)-               (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,-               W.mapWithKey                    -- when descending ...-                 (\ k r es -> tryWith (TryF qfn k) (r es))-                 (fmap fst ts)-    go (SChoiceF qsn _ gr _     ts)            =-      backjump mbj enableBj fineGrainedConflicts-               (\_ _ -> Nothing)-               (const logSkippedChoiceSimple)-               (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,-               W.mapWithKey                    -- when descending ...-                 (\ k r es -> tryWith (TryS qsn k) (r es))-                 (fmap fst ts)-    go (GoalChoiceF _           ts)            = \ es ->-      let (k, (v, tree)) = getBestGoal' ts (esConflictMap es)-      in continueWith (Next k) $-         -- Goal choice nodes are normally not counted as backjumps, since the-         -- solver always explores exactly one choice, which means that the-         -- backjump from the goal choice would be redundant with the backjump-         -- from the PChoice, FChoice, or SChoice below. The one case where the-         -- backjump is not redundant is when the chosen goal is a failure node,-         -- so we log a backjump in that case.-         case tree of-           Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj-           _        -> v es--    initES = ES {-        esConflictMap = M.empty-      , esBackjumps = 0-      }--    -- Is it possible for this package instance (QPN and POption) to resolve any-    -- of the conflicts that were caused by the previous instance? The default-    -- is true, because it is always safe to explore a package instance.-    -- Skipping it is an optimization. If false, it returns a new conflict set-    -- to be merged with the previous one.-    couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet-    couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =-      let (PInfo deps _ _ _) = idx M.! pn M.! i-          qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps--          couldBeResolved :: CS.Conflict -> Maybe ConflictSet-          couldBeResolved CS.OtherConflict = Nothing-          couldBeResolved (CS.GoalConflict conflictingDep) =-              -- Check whether this package instance also has 'conflictingDep'-              -- as a dependency (ignoring flag and stanza choices).-              if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep]-              then Nothing-              else Just CS.empty-          couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) =-              -- Check whether this package instance also excludes version-              -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices).-              let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ]-                  vrIntersection = L.foldl' (.&&.) anyVersion vrs-              in if checkVR vrIntersection excludedVersion-                 then Nothing-                 else -- If we skip this package instance, we need to update the-                      -- conflict set to say that 'dep' was also excluded by-                      -- this package instance's constraint.-                      Just $ CS.singletonWithConflict (P dep) $-                      CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection)-          couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) =-              -- Check whether this package instance's version is also excluded-              -- by 'excludingVR'.-              if checkVR excludingVR v-              then Nothing-              else -- If we skip this version, we need to update the conflict-                   -- set to say that the reverse dependency also excluded this-                   -- version.-                   Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v)-      in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts)--    logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a-    logSkippedPackage qpn pOption cs es =-        tryWith (TryP qpn pOption) $-        failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $-        NoSolution cs es--    -- This function is used for flag and stanza choices, but it should not be-    -- called, because there is currently no way to skip a value for a flag or-    -- stanza.-    logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a-    logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es---- | Build a conflict set corresponding to the (virtual) option not to--- choose a solution for a goal at all.------ In the solver, the set of goals is not statically determined, but depends--- on the choices we make. Therefore, when dealing with conflict sets, we--- always have to consider that we could perhaps make choices that would--- avoid the existence of the goal completely.------ Whenever we actually introduce a choice in the tree, we have already established--- that the goal cannot be avoided. This is tracked in the "goal reason".--- The choice to avoid the goal therefore is a conflict between the goal itself--- and its goal reason. We build this set here, and pass it to the 'backjump'--- function as the last conflict set.------ This has two effects:------ - In a situation where there are no choices available at all (this happens--- if an unknown package is requested), the last conflict set becomes the--- actual conflict set.------ - In a situation where all of the children's conflict sets contain the--- current variable, the goal reason of the current node will be added to the--- conflict set.----avoidSet :: Var QPN -> QGoalReason -> ConflictSet-avoidSet var@(P qpn) gr =-  CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr)-avoidSet var         gr =-  CS.union (CS.singleton var) (goalReasonToConflictSet gr)---- | Interface.------ Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing',--- then infinitely many backjumps are allowed. If the limit is 'Just 0',--- backtracking is completely disabled.-backjumpAndExplore :: Maybe Int-                   -> EnableBackjumping-                   -> FineGrainedConflicts-                   -> CountConflicts-                   -> Index-                   -> Tree d QGoalReason-                   -> RetryLog Message SolverFailure (Assignment, RevDepMap)-backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx =-    mapFailure convertFailure-  . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx-  . assign-  where-    convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es)-    convertFailure BackjumpLimit      = BackjumpLimitReached
− Distribution/Solver/Modular/Flag.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Solver.Modular.Flag-    ( FInfo(..)-    , Flag-    , FlagInfo-    , FN(..)-    , QFN-    , QSN-    , Stanza-    , SN(..)-    , WeakOrTrivial(..)-    , FlagValue(..)-    , mkFlag-    , showQFN-    , showQFNBool-    , showFlagValue-    , showQSN-    , showQSNBool-    , showSBool-    ) where--import Data.Map as M-import Prelude hiding (pi)--import qualified Distribution.PackageDescription as P -- from Cabal--import Distribution.Solver.Types.Flag-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath---- | Flag name. Consists of a package instance and the flag identifier itself.-data FN qpn = FN qpn Flag-  deriving (Eq, Ord, Show, Functor)---- | Flag identifier. Just a string.-type Flag = P.FlagName---- | Stanza identifier.-type Stanza = OptionalStanza--unFlag :: Flag -> String-unFlag = P.unFlagName--mkFlag :: String -> Flag-mkFlag = P.mkFlagName---- | Flag info. Default value, whether the flag is manual, and--- whether the flag is weak. Manual flags can only be set explicitly.--- Weak flags are typically deferred by the solver.-data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial }-  deriving (Eq, Show)---- | Flag defaults.-type FlagInfo = Map Flag FInfo---- | Qualified flag name.-type QFN = FN QPN---- | Stanza name. Paired with a package name, much like a flag.-data SN qpn = SN qpn Stanza-  deriving (Eq, Ord, Show, Functor)---- | Qualified stanza name.-type QSN = SN QPN---- | A property of flag and stanza choices that determines whether the--- choice should be deferred in the solving process.------ A 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.------ 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 the choice.-newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }-  deriving (Eq, Ord, Show)---- | Value shown for a flag in a solver log message. The message can refer to--- only the true choice, only the false choice, or both choices.-data FlagValue = FlagTrue | FlagFalse | FlagBoth-  deriving (Eq, Show)--showQFNBool :: QFN -> Bool -> String-showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b--showQSNBool :: QSN -> Bool -> String-showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b--showFBool :: FN qpn -> Bool -> String-showFBool (FN _ f) v = P.showFlagValue (f, v)---- | String representation of a flag-value pair.-showFlagValue :: P.FlagName -> FlagValue -> String-showFlagValue f FlagTrue  = '+' : unFlag f-showFlagValue f FlagFalse = '-' : unFlag f-showFlagValue f FlagBoth  = "+/-" ++ unFlag f--showSBool :: Stanza -> Bool -> String-showSBool s True  = "*" ++ showStanza s-showSBool s False = "!" ++ showStanza s--showQFN :: QFN -> String-showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f--showQSN :: QSN -> String-showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s
− Distribution/Solver/Modular/Index.hs 
@@ -1,74 +0,0 @@-module Distribution.Solver.Modular.Index-    ( Index-    , PInfo(..)-    , ComponentInfo(..)-    , IsVisible(..)-    , IsBuildable(..)-    , defaultQualifyOptions-    , mkIndex-    ) where--import Prelude hiding (pi)--import Data.Map (Map)-import qualified Data.List as L-import qualified Data.Map as M--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree---- | An index contains information about package instances. This is a nested--- dictionary. Package names are mapped to instances, which in turn is mapped--- to info.-type Index = Map PN (Map I PInfo)---- | Info associated with a package instance.--- Currently, dependencies, component names, flags and failure reasons.--- The component map records whether any components are unbuildable in the--- current environment (compiler, os, arch, and global flag constraints).--- Packages that have a failure reason recorded for them are disabled--- globally, for reasons external to the solver. We currently use this--- for shadowing which essentially is a GHC limitation, and for--- installed packages that are broken.-data PInfo = PInfo (FlaggedDeps PN)-                   (Map ExposedComponent ComponentInfo)-                   FlagInfo-                   (Maybe FailReason)---- | Info associated with each library and executable in a package instance.-data ComponentInfo = ComponentInfo {-    compIsVisible   :: IsVisible-  , compIsBuildable :: IsBuildable-  }-  deriving Show---- | Whether a component is visible in the current environment.-newtype IsVisible = IsVisible Bool-  deriving (Eq, Show)---- | Whether a component is made unbuildable by a "buildable: False" field.-newtype IsBuildable = IsBuildable Bool-  deriving (Eq, Show)--mkIndex :: [(PN, I, PInfo)] -> Index-mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))--groupMap :: Ord a => [(a, b)] -> Map a [b]-groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)--defaultQualifyOptions :: Index -> QualifyOptions-defaultQualifyOptions idx = QO {-      qoBaseShim         = or [ dep == base-                              | -- Find all versions of base ..-                                Just is <- [M.lookup base idx]-                                -- .. which are installed ..-                              , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is-                                -- .. and flatten all their dependencies ..-                              , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps-                              ]-    , qoSetupIndependent = True-    }-  where-    base = mkPackageName "base"
− Distribution/Solver/Modular/IndexConversion.hs 
@@ -1,562 +0,0 @@-module Distribution.Solver.Modular.IndexConversion-    ( convPIs-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Data.List as L-import qualified Data.Map.Strict as M-import qualified Distribution.Compat.NonEmptySet as NonEmptySet-import qualified Data.Set as S--import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Compiler-import Distribution.Package                          -- from Cabal-import Distribution.Simple.BuildToolDepends          -- from Cabal-import Distribution.Types.ExeDependency              -- from Cabal-import Distribution.Types.PkgconfigDependency        -- from Cabal-import Distribution.Types.ComponentName              -- from Cabal-import Distribution.Types.CondTree                   -- from Cabal-import Distribution.Types.MungedPackageId            -- from Cabal-import Distribution.Types.MungedPackageName          -- from Cabal-import Distribution.PackageDescription               -- from Cabal-import Distribution.PackageDescription.Configuration-import qualified Distribution.Simple.PackageIndex as SI-import Distribution.System--import           Distribution.Solver.Types.ComponentDeps-                   ( Component(..), componentNameToComponent )-import           Distribution.Solver.Types.Flag-import           Distribution.Solver.Types.LabeledPackageConstraint-import           Distribution.Solver.Types.OptionalStanza-import           Distribution.Solver.Types.PackageConstraint-import qualified Distribution.Solver.Types.PackageIndex as CI-import           Distribution.Solver.Types.Settings-import           Distribution.Solver.Types.SourcePackage--import Distribution.Solver.Modular.Dependency as D-import Distribution.Solver.Modular.Flag as F-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version---- | Convert both the installed package index and the source package--- index into one uniform solver index.------ We use 'allPackagesBySourcePackageId' for the installed package index--- because that returns us several instances of the same package and version--- in order of preference. This allows us in principle to \"shadow\"--- packages if there are several installed packages of the same version.--- There are currently some shortcomings in both GHC and Cabal in--- 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 -> CompilerInfo -> Map PN [LabeledPackageConstraint]-        -> ShadowPkgs -> StrongFlags -> SolveExecutables-        -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)-        -> Index-convPIs os arch comp constraints sip strfl solveExes iidx sidx =-  mkIndex $-  convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx---- | Convert a Cabal installed package index to the simpler,--- more uniform index format of the solver.-convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]-convIPI' (ShadowPkgs sip) idx =-    -- apply shadowing whenever there are multiple installed packages with-    -- the same version-    [ maybeShadow (convIP idx pkg)-    -- IMPORTANT to get internal libraries. See-    -- Note [Index conversion with internal libraries]-    | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx-    , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]-  where--    -- shadowing is recorded in the package info-    shadow (pn, i, PInfo fdeps comps fds _)-      | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed))-    shadow x                                     = x---- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.-convId :: IPI.InstalledPackageInfo -> (PN, I)-convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)-  where MungedPackageId mpn ver = mungedId ipi-        -- HACK. See Note [Index conversion with internal libraries]-        pn = encodeCompatPackageName mpn---- | Convert a single installed package into the solver-specific format.-convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)-convIP idx ipi =-  case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of-        Left u    -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))-        Right fds -> (pn, i, PInfo fds components M.empty Nothing)- where-  -- TODO: Handle sub-libraries and visibility.-  components =-      M.singleton (ExposedLib LMainLibName)-                  ComponentInfo {-                      compIsVisible = IsVisible True-                    , compIsBuildable = IsBuildable True-                    }--  (pn, i) = convId ipi--  -- 'sourceLibName' is unreliable, but for now we only really use this for-  -- primary libs anyways-  comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi--- TODO: Installed packages should also store their encapsulations!---- Note [Index conversion with internal libraries]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Something very interesting happens when we have internal libraries--- in our index.  In this case, we maybe have p-0.1, which itself--- depends on the internal library p-internal ALSO from p-0.1.--- Here's the danger:------      - If we treat both of these packages as having PN "p",---        then the solver will try to pick one or the other,---        but never both.------      - If we drop the internal packages, now p-0.1 has a---        dangling dependency on an "installed" package we know---        nothing about. Oops.------ An expedient hack is to put p-internal into cabal-install's--- index as a MUNGED package name, so that it doesn't conflict--- with anyone else (except other instances of itself).  But--- yet, we ought NOT to say that PNs in the solver are munged--- package names, because they're not; for source packages,--- we really will never see munged package names.------ The tension here is that the installed package index is actually--- per library, but the solver is per package.  We need to smooth--- it over, and munging the package names is a pretty good way to--- do it.---- | Convert dependencies specified by an installed package id into--- flagged dependencies of the solver.------ May return Nothing if the package can't be found in the index. That--- indicates that the original package having this dependency is broken--- and should be ignored.-convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)-convIPId dr comp idx ipid =-  case SI.lookupUnitId idx ipid of-    Nothing  -> Left ipid-    Just ipi -> let (pn, i) = convId ipi-                    name = ExposedLib LMainLibName  -- TODO: Handle sub-libraries.-                in  Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)-                -- NB: something we pick up from the-                -- InstalledPackageIndex is NEVER an executable---- | Convert a cabal-install source package index to the simpler,--- more uniform index format of the solver.-convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]-         -> StrongFlags -> SolveExecutables-         -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]-convSPI' os arch cinfo constraints strfl solveExes =-    L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages---- | Convert a single source package into the solver-specific format.-convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]-       -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)-convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =-  let i = I pv InRepo-      pkgConstraints = fromMaybe [] $ M.lookup pn constraints-  in  (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)---- We do not use 'flattenPackageDescription' or 'finalizePD'--- from 'Distribution.PackageDescription.Configuration' here, because we--- want to keep the condition tree, but simplify much of the test.---- | Convert a generic package description to a solver-specific 'PInfo'.-convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]-        -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription-        -> PInfo-convGPD os arch cinfo constraints strfl solveExes pn-        (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) =-  let-    fds  = flagInfo strfl flags---    conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->-            CondTree ConfVar [Dependency] a -> FlaggedDeps PN-    conv comp getInfo dr =-        convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes .-        addBuildableCondition getInfo--    initDR = DependencyReason pn M.empty S.empty--    flagged_deps-        = concatMap (\ds ->       conv ComponentLib         libBuildInfo        initDR ds) (maybeToList mlib)-       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo        initDR ds) sub_libs-       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)   foreignLibBuildInfo initDR ds) flibs-       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)    buildInfo           initDR ds) exes-       ++ prefix (Stanza (SN pn TestStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentTest nm)   testBuildInfo (addStanza TestStanzas initDR) ds)-                    tests)-       ++ prefix (Stanza (SN pn BenchStanzas))-            (L.map  (\(nm, ds) -> conv (ComponentBench nm)  benchmarkBuildInfo (addStanza BenchStanzas initDR) ds)-                    benchs)-       ++ maybe []  (convSetupBuildInfo pn) (setupBuildInfo pkg)--    addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn-    addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss)--    -- | A too-new specVersion is turned into a global 'FailReason'-    -- which prevents the solver from selecting this release (and if-    -- forced to, emit a meaningful solver error message).-    fr = case scannedVersion of-        Just ver -> Just (UnsupportedSpecVer ver)-        Nothing  -> Nothing--    components :: Map ExposedComponent ComponentInfo-    components = M.fromList $ libComps ++ subLibComps ++ exeComps-      where-        libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib)-                   | lib <- maybeToList mlib ]-        subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib)-                      | (name, lib) <- sub_libs ]-        exeComps = [ ( ExposedExe name-                     , ComponentInfo {-                           compIsVisible = IsVisible True-                         , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False-                         }-                     )-                   | (name, exe) <- exes ]--        libToComponentInfo lib =-            ComponentInfo {-                compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True-              , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False-              }--        testCondition = testConditionForComponent os arch cinfo constraints--        isPrivate LibraryVisibilityPrivate = True-        isPrivate LibraryVisibilityPublic  = False--  in PInfo flagged_deps components fds fr---- | Applies the given predicate (for example, testing buildability or--- visibility) to the given component and environment. Values are combined with--- AND. This function returns 'Nothing' when the result cannot be determined--- before dependency solving. Additionally, this function only considers flags--- that are set by unqualified flag constraints, and it doesn't check the--- intra-package dependencies of a component.-testConditionForComponent :: OS-                          -> Arch-                          -> CompilerInfo-                          -> [LabeledPackageConstraint]-                          -> (a -> Bool)-                          -> CondTree ConfVar [Dependency] a-                          -> Maybe Bool-testConditionForComponent os arch cinfo constraints p tree =-    case go $ extractCondition p tree of-      Lit True  -> Just True-      Lit False -> Just False-      _         -> Nothing-  where-    flagAssignment :: [(FlagName, Bool)]-    flagAssignment =-        mconcat [ unFlagAssignment fa-                | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)-                    <- L.map unlabelPackageConstraint constraints]--    -- Simplify the condition, using the current environment. Most of this-    -- function was copied from convBranch and-    -- Distribution.Types.Condition.simplifyCondition.-    go :: Condition ConfVar -> Condition ConfVar-    go (Var (OS os')) = Lit (os == os')-    go (Var (Arch arch')) = Lit (arch == arch')-    go (Var (Impl cf cvr))-        | matchImpl (compilerInfoId cinfo) ||-              -- fixme: Nothing should be treated as unknown, rather than empty-              --        list. This code should eventually be changed to either-              --        support partial resolution of compiler flags or to-              --        complain about incompletely configured compilers.-          any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True-        | otherwise = Lit False-      where-        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv-    go (Var (PackageFlag f))-        | Just b <- L.lookup f flagAssignment = Lit b-    go (Var v) = Var v-    go (Lit b) = Lit b-    go (CNot c) =-        case go c of-          Lit True -> Lit False-          Lit False -> Lit True-          c' -> CNot c'-    go (COr c d) =-        case (go c, go d) of-          (Lit False, d') -> d'-          (Lit True, _)   -> Lit True-          (c', Lit False) -> c'-          (_, Lit True)   -> Lit True-          (c', d')        -> COr c' d'-    go (CAnd c d) =-        case (go c, go d) of-          (Lit False, _) -> Lit False-          (Lit True, d') -> d'-          (_, Lit False) -> Lit False-          (c', Lit True) -> c'-          (c', d')       -> CAnd c' d'---- | Create a flagged dependency tree from a list @fds@ of flagged--- dependencies, using @f@ to form the tree node (@f@ will be--- something like @Stanza sn@).-prefix :: (FlaggedDeps qpn -> FlaggedDep qpn)-       -> [FlaggedDeps qpn] -> FlaggedDeps qpn-prefix _ []  = []-prefix f fds = [f (concat fds)]---- | Convert flag information. Automatic flags are now considered weak--- unless strong flags have been selected explicitly.-flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo-flagInfo (StrongFlags strfl) =-    M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m)))-  where-    weak m = WeakOrTrivial $ not (strfl || m)-    flagType m = if m then Manual else Automatic---- | Convert condition trees to flagged dependencies.  Mutually--- recursive with 'convBranch'.  See 'convBranch' for an explanation--- of all arguments preceding the input 'CondTree'.-convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->-                Component ->-                (a -> BuildInfo) ->-                SolveExecutables ->-                CondTree ConfVar [Dependency] a -> FlaggedDeps PN-convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =-             -- Merge all library and build-tool dependencies at every level in-             -- the tree of flagged dependencies. Otherwise 'extractCommon'-             -- could create duplicate dependencies, and the number of-             -- duplicates could grow exponentially from the leaves to the root-             -- of the tree.-             mergeSimpleDeps $-                 [ D.Simple singleDep comp-                 | dep <- ds-                 , singleDep <- convLibDeps dr dep ]  -- unconditional package dependencies--              ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (allExtensions bi) -- unconditional extension dependencies-              ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages  bi) -- unconditional language dependencies-              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies-              ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches-              -- build-tools dependencies-              -- NB: Only include these dependencies if SolveExecutables-              -- is True.  It might be false in the legacy solver-              -- codepath, in which case there won't be any record of-              -- an executable we need.-              ++ [ D.Simple (convExeDep dr exeDep) comp-                 | solveExes'-                 , exeDep <- getAllToolDependencies pkg bi-                 , not $ isInternal pkg exeDep-                 ]-  where-    bi = getInfo info--data SimpleFlaggedDepKey qpn =-    SimpleFlaggedDepKey (PkgComponent qpn) Component-  deriving (Eq, Ord)--data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR---- | Merge 'Simple' dependencies that apply to the same library or build-tool.--- This function should be able to merge any two dependencies that can be merged--- by extractCommon, in order to prevent the exponential growth of dependencies.------ Note that this function can merge dependencies that have different--- DependencyReasons, which can make the DependencyReasons less precise. This--- loss of precision only affects performance and log messages, not correctness.--- However, when 'mergeSimpleDeps' is only called on dependencies at a single--- location in the dependency tree, the only difference between--- DependencyReasons should be flags that have value FlagBoth. Adding extra--- flags with value FlagBoth should not affect performance, since they are not--- added to the conflict set. The only downside is the possibility of the log--- incorrectly saying that the flag contributed to excluding a specific version--- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB--- introduces pkg <5, the merged dependency would mean that--- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply--- that +/-flagA excludes pkg-6.-mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn-mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged-  where-    (merged, unmerged) = L.foldl' f (M.empty, []) deps-      where-        f :: Ord qpn-          => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)-          -> FlaggedDep qpn-          -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)-        f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) =-            ( M.insertWith mergeValues-                           (SimpleFlaggedDepKey dep comp)-                           (SimpleFlaggedDepValue dr vr)-                           merged'-            , unmerged')-        f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged')--        mergeValues :: SimpleFlaggedDepValue qpn-                    -> SimpleFlaggedDepValue qpn-                    -> SimpleFlaggedDepValue qpn-        mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) =-            SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2)--    toFlaggedDep :: SimpleFlaggedDepKey qpn-                 -> SimpleFlaggedDepValue qpn-                 -> FlaggedDep qpn-    toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) =-        D.Simple (LDep dr (Dep dep (Constrained vr))) comp---- | Branch interpreter.  Mutually recursive with 'convCondTree'.------ Here, we try to simplify one of Cabal's condition tree branches into the--- solver's flagged dependency format, which is weaker. Condition trees can--- contain complex logical expression composed from flag choices and special--- flags (such as architecture, or compiler flavour). We try to evaluate the--- special flags and subsequently simplify to a tree that only depends on--- simple flag choices.------ This function takes a number of arguments:------      1. A map of flag values that have already been chosen. It allows---         convBranch to avoid creating nested FlaggedDeps that are---         controlled by the same flag and avoid creating DependencyReasons with---         conflicting values for the same flag.------      2. The DependencyReason calculated at this point in the tree of---         conditionals. The flag values in the DependencyReason are similar to---         the values in the map above, except for the use of FlagBoth.------      3. Some pre dependency-solving known information ('OS', 'Arch',---         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,------      4. The package name @'PN'@ which this condition tree---         came from, so that we can correctly associate @flag()@---         variables with the correct package name qualifier,------      5. The flag defaults 'FlagInfo' so that we can populate---         'Flagged' dependencies with 'FInfo',------      6. The name of the component 'Component' so we can record where---         the fine-grained information about where the component came---         from (see 'convCondTree'), and------      7. A selector to extract the 'BuildInfo' from the leaves of---         the 'CondTree' (which actually contains the needed---         dependency information.)------      8. The set of package names which should be considered internal---         dependencies, and thus not handled as dependencies.-convBranch :: Map FlagName Bool-           -> DependencyReason PN-           -> PackageDescription-           -> OS-           -> Arch-           -> CompilerInfo-           -> PN-           -> FlagInfo-           -> Component-           -> (a -> BuildInfo)-           -> SolveExecutables-           -> CondBranch ConfVar [Dependency] a-           -> FlaggedDeps PN-convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') =-    go c'-       (\flags' dr' ->           convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes  t')-       (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf')-       flags dr-  where-    go :: Condition ConfVar-       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)-       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)-       ->  Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN-    go (Lit True)  t _ = t-    go (Lit False) _ f = f-    go (CNot c)    t f = go c f t-    go (CAnd c d)  t f = go c (go d t f) f-    go (COr  c d)  t f = go c t (go d t f)-    go (Var (PackageFlag fn)) t f = \flags' ->-        case M.lookup fn flags' of-          Just True  -> t flags'-          Just False -> f flags'-          Nothing    -> \dr' ->-            -- Add each flag to the DependencyReason for all dependencies below,-            -- including any extracted dependencies. Extracted dependencies are-            -- introduced by both flag values (FlagBoth). Note that we don't-            -- actually need to add the flag to the extracted dependencies for-            -- correct backjumping; the information only improves log messages-            -- by giving the user the full reason for each dependency.-            let addFlagValue v = addFlagToDependencyReason fn v dr'-                addFlag v = M.insert fn v flags'-            in extractCommon (t (addFlag True)  (addFlagValue FlagBoth))-                             (f (addFlag False) (addFlagValue FlagBoth))-                ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True)  (addFlagValue FlagTrue))-                                                     (f (addFlag False) (addFlagValue FlagFalse)) ]-    go (Var (OS os')) t f-      | os == os'      = t-      | otherwise      = f-    go (Var (Arch arch')) t f-      | arch == arch'  = t-      | otherwise      = f-    go (Var (Impl cf cvr)) t f-      | matchImpl (compilerInfoId cinfo) ||-            -- fixme: Nothing should be treated as unknown, rather than empty-            --        list. This code should eventually be changed to either-            --        support partial resolution of compiler flags or to-            --        complain about incompletely configured compilers.-        any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t-      | otherwise      = f-      where-        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv--    addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn-    addFlagToDependencyReason fn v (DependencyReason pn' fs ss) =-        DependencyReason pn' (M.insert fn v fs) ss--    -- If both branches contain the same package as a simple dep, we lift it to-    -- the next higher-level, but with the union of version ranges. This-    -- heuristic together with deferring flag choices will then usually first-    -- resolve this package, and try an already installed version before imposing-    -- a default flag choice that might not be what we want.-    ---    -- Note that we make assumptions here on the form of the dependencies that-    -- can occur at this point. In particular, no occurrences of Fixed, as all-    -- dependencies below this point have been generated using 'convLibDep'.-    ---    -- WARNING: This is quadratic!-    extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn-    extractCommon ps ps' =-        -- Union the DependencyReasons, because the extracted dependency can be-        -- avoided by removing the dependency from either side of the-        -- conditional.-        [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp-        | D.Simple (LDep vs1                (Dep dep1 (Constrained vr1))) _ <- ps-        , D.Simple (LDep vs2                (Dep dep2 (Constrained vr2))) _ <- ps'-        , dep1 == dep2-        ]---- | Merge DependencyReasons by unioning their variables.-unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn-unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =-    DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2)---- | Convert a Cabal dependency on a set of library components (from a single--- package) to solver-specific dependencies.-convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN]-convLibDeps dr (Dependency pn vr libs) =-    [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr)-    | lib <- NonEmptySet.toList libs ]---- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.-convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN-convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr)---- | Convert setup dependencies-convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN-convSetupBuildInfo pn nfo =-    [ D.Simple singleDep ComponentSetup-    | dep <- setupDepends nfo-    , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ]
− Distribution/Solver/Modular/LabeledGraph.hs 
@@ -1,117 +0,0 @@--- | Wrapper around Data.Graph with support for edge labels-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.LabeledGraph (-    -- * Graphs-    Graph-  , Vertex-    -- ** Building graphs-  , graphFromEdges-  , graphFromEdges'-  , buildG-  , transposeG-    -- ** Graph properties-  , vertices-  , edges-    -- ** Operations on the underlying unlabeled graph-  , forgetLabels-  , topSort-  ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Data.Array-import Data.Graph (Vertex, Bounds)-import qualified Data.Graph as G--{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}--type Graph e = Array Vertex [(e, Vertex)]-type Edge  e = (Vertex, e, Vertex)--{--------------------------------------------------------------------------------  Building graphs--------------------------------------------------------------------------------}---- | Construct an edge-labeled graph------ This is a simple adaptation of the definition in Data.Graph-graphFromEdges :: forall key node edge. Ord key-               => [ (node, key, [(edge, key)]) ]-               -> ( Graph edge-                  , Vertex -> (node, key, [(edge, key)])-                  , key -> Maybe Vertex-                  )-graphFromEdges edges0 =-    (graph, \v -> vertex_map ! v, key_vertex)-  where-    max_v        = length edges0 - 1-    bounds0      = (0, max_v) :: (Vertex, Vertex)-    sorted_edges = sortBy lt edges0-    edges1       = zip [0..] sorted_edges--    graph        = array bounds0 [(v, (mapMaybe mk_edge ks))-                                 | (v, (_, _, ks)) <- edges1]-    key_map      = array bounds0 [(v, k                    )-                                 | (v, (_, k, _ )) <- edges1]-    vertex_map   = array bounds0 edges1--    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2--    mk_edge :: (edge, key) -> Maybe (edge, Vertex)-    mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)--    --  returns Nothing for non-interesting vertices-    key_vertex :: key -> Maybe Vertex-    key_vertex k = findVertex 0 max_v-      where-        findVertex a b-          | a > b     = Nothing-          | otherwise = case compare k (key_map ! mid) of-              LT -> findVertex a (mid-1)-              EQ -> Just mid-              GT -> findVertex (mid+1) b-          where-            mid = a + (b - a) `div` 2--graphFromEdges' :: Ord key-                => [ (node, key, [(edge, key)]) ]-                -> ( Graph edge-                   , Vertex -> (node, key, [(edge, key)])-                   )-graphFromEdges' x = (a,b)-  where-    (a,b,_) = graphFromEdges x--transposeG :: Graph e -> Graph e-transposeG g = buildG (bounds g) (reverseE g)--buildG :: Bounds -> [Edge e] -> Graph e-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)-  where-    reassoc (v, e, w) = (v, (e, w))--reverseE :: Graph e -> [Edge e]-reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]--{--------------------------------------------------------------------------------  Graph properties--------------------------------------------------------------------------------}--vertices :: Graph e -> [Vertex]-vertices = indices--edges :: Graph e -> [Edge e]-edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]--{--------------------------------------------------------------------------------  Operations on the underlying unlabelled graph--------------------------------------------------------------------------------}--forgetLabels :: Graph e -> G.Graph-forgetLabels = fmap (map snd)--topSort :: Graph e -> [Vertex]-topSort = G.topSort . forgetLabels
− Distribution/Solver/Modular/Linking.hs 
@@ -1,519 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- TODO: remove this-{-# OPTIONS -fno-warn-incomplete-uni-patterns #-}-module Distribution.Solver.Modular.Linking (-    validateLinking-  ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (get,put)--import Control.Exception (assert)-import Control.Monad.Reader-import Control.Monad.State-import Data.Map ((!))-import qualified Data.Map         as M-import qualified Data.Set         as S-import qualified Data.Traversable as T--import Distribution.Client.Utils.Assertion-import Distribution.Solver.Modular.Assignment-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.ConflictSet as CS-import qualified Distribution.Solver.Modular.WeightedPSQ as W--import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath-import Distribution.Types.Flag (unFlagName)--{--------------------------------------------------------------------------------  Validation--  Validation of links is a separate pass that's performed after normal-  validation. Validation of links checks that if the tree indicates that a-  package is linked, then everything underneath that choice really matches the-  package we have linked to.--  This is interesting because it isn't unidirectional. Consider that we've-  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.-  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that-  a.bar and b.bar are also linked. However, it's not required that we actually-  choose a.bar before b.bar. Goal choice order is relatively free. It's possible-  that we choose a.bar first, but also possible that we choose b.bar first. In-  both cases, we have to recognize that we have freedom of choice for the first-  of the two, but no freedom of choice for the second.--  This is what LinkGroups are all about. Using LinkGroup, we can record (in the-  situation above) that a.bar and b.bar need to be linked even if we haven't-  chosen either of them yet.--------------------------------------------------------------------------------}--data ValidateState = VS {-      vsIndex    :: Index-    , vsLinks    :: Map QPN LinkGroup-    , vsFlags    :: FAssignment-    , vsStanzas  :: SAssignment-    , vsQualifyOptions :: QualifyOptions--    -- Saved qualified dependencies. Every time 'validateLinking' makes a-    -- package choice, it qualifies the package's dependencies and saves them in-    -- this map. Then the qualified dependencies are available for subsequent-    -- flag and stanza choices for the same package.-    , vsSaved    :: Map QPN (FlaggedDeps QPN)-    }--type Validate = Reader ValidateState---- | Validate linked packages------ Verify that linked packages have------ * Linked dependencies,--- * Equal flag assignments--- * Equal stanza assignments-validateLinking :: Index -> Tree d c -> Tree d c-validateLinking index = (`runReader` initVS) . cata go-  where-    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)--    go (PChoiceF qpn rdm gr       cs) =-      PChoice qpn rdm gr       <$> T.sequence (W.mapWithKey (goP qpn) cs)-    go (FChoiceF qfn rdm gr t m d cs) =-      FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs)-    go (SChoiceF qsn rdm gr t     cs) =-      SChoice qsn rdm gr t     <$> T.sequence (W.mapWithKey (goS qsn) cs)--    -- For the other nodes we just recurse-    go (GoalChoiceF rdm           cs) = GoalChoice rdm <$> T.sequence cs-    go (DoneF revDepMap s)            = return $ Done revDepMap s-    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason--    -- Package choices-    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)-    goP qpn@(Q _pp pn) opt@(POption i _) r = do-      vs <- ask-      let PInfo deps _ _ _ = vsIndex vs ! pn ! i-          qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps-          newSaved         = M.insert qpn qdeps (vsSaved vs)-      case execUpdateState (pickPOption qpn opt qdeps) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs' { vsSaved = newSaved }) r--    -- Flag choices-    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goF qfn b r = do-      vs <- ask-      case execUpdateState (pickFlag qfn b) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    -- Stanza choices (much the same as flag choices)-    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goS qsn b r = do-      vs <- ask-      case execUpdateState (pickStanza qsn b) vs of-        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)-        Right vs'       -> local (const vs') r--    initVS :: ValidateState-    initVS = VS {-        vsIndex   = index-      , vsLinks   = M.empty-      , vsFlags   = M.empty-      , vsStanzas = M.empty-      , vsQualifyOptions = defaultQualifyOptions index-      , vsSaved   = M.empty-      }--{--------------------------------------------------------------------------------  Updating the validation state--------------------------------------------------------------------------------}--type Conflict = (ConflictSet, String)--newtype UpdateState a = UpdateState {-    unUpdateState :: StateT ValidateState (Either Conflict) a-  }-  deriving (Functor, Applicative, Monad)--instance MonadState ValidateState UpdateState where-  get    = UpdateState $ get-  put st = UpdateState $ do-             expensiveAssert (lgInvariant $ vsLinks st) $ return ()-             put st--lift' :: Either Conflict a -> UpdateState a-lift' = UpdateState . lift--conflict :: Conflict -> UpdateState a-conflict = lift' . Left--execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState-execUpdateState = execStateT . unUpdateState--pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()-pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i-pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps--pickConcrete :: QPN -> I -> UpdateState ()-pickConcrete qpn@(Q pp _) i = do-    vs <- get-    case M.lookup qpn (vsLinks vs) of-      -- Package is not yet in a LinkGroup. Create a new singleton link group.-      Nothing -> do-        let lg = lgSingleton qpn (Just $ PI pp i)-        updateLinkGroup lg--      -- Package is already in a link group. Since we are picking a concrete-      -- instance here, it must by definition be the canonical package.-      Just lg ->-        makeCanonical lg qpn i--pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()-pickLink qpn@(Q _pp pn) i pp' deps = do-    vs <- get--    -- The package might already be in a link group-    -- (because one of its reverse dependencies is)-    let lgSource = case M.lookup qpn (vsLinks vs) of-                     Nothing -> lgSingleton qpn Nothing-                     Just lg -> lg--    -- Find the link group for the package we are linking to-    ---    -- Since the builder never links to a package without having first picked a-    -- concrete instance for that package, and since we create singleton link-    -- groups for concrete instances, this link group must exist (and must-    -- in fact already have a canonical member).-    let target   = Q pp' pn-        lgTarget = vsLinks vs ! target--    -- Verify here that the member we add is in fact for the same package and-    -- matches the version of the canonical instance. However, violations of-    -- these checks would indicate a bug in the linker, not a true conflict.-    let sanityCheck :: Maybe (PI PackagePath) -> Bool-        sanityCheck Nothing              = False-        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI-    assert (sanityCheck (lgCanon lgTarget)) $ return ()--    -- Merge the two link groups (updateLinkGroup will propagate the change)-    lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget-    updateLinkGroup lgTarget'--    -- Make sure all dependencies are linked as well-    linkDeps target deps--makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()-makeCanonical lg qpn@(Q pp _) i =-    case lgCanon lg of-      -- There is already a canonical member. Fail.-      Just _ ->-        conflict ( CS.insert (P qpn) (lgConflictSet lg)-                 ,    "cannot make " ++ showQPN qpn-                   ++ " canonical member of " ++ showLinkGroup lg-                 )-      Nothing -> do-        let lg' = lg { lgCanon = Just (PI pp i) }-        updateLinkGroup lg'---- | Link the dependencies of linked parents.------ When we decide to link one package against another we walk through the--- package's direct depedencies and make sure that they're all linked to each--- other by merging their link groups (or creating new singleton link groups if--- they don't have link groups yet). We do not need to do this recursively,--- because having the direct dependencies in a link group means that we must--- have already made or will make sooner or later a link choice for one of these--- as well, and cover their dependencies at that point.-linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()-linkDeps target = \deps -> do-    -- linkDeps is called in two places: when we first link one package to-    -- another, and when we discover more dependencies of an already linked-    -- package after doing some flag assignment. It is therefore important that-    -- flag assignments cannot influence _how_ dependencies are qualified;-    -- fortunately this is a documented property of 'qualifyDeps'.-    rdeps <- requalify deps-    go deps rdeps-  where-    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()-    go = zipWithM_ go1--    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()-    go1 dep rdep = case (dep, rdep) of-      (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do-        vs <- get-        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs-            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs-        lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg'-        updateLinkGroup lg''-      (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do-        vs <- get-        case M.lookup fn (vsFlags vs) of-          Nothing    -> return () -- flag assignment not yet known-          Just True  -> go t t'-          Just False -> go f f'-      (Stanza sn t, ~(Stanza _ t')) -> do-        vs <- get-        case M.lookup sn (vsStanzas vs) of-          Nothing    -> return () -- stanza assignment not yet known-          Just True  -> go t t'-          Just False -> return () -- stanza not enabled; no new deps-    -- For extensions and language dependencies, there is nothing to do.-    -- No choice is involved, just checking, so there is nothing to link.-    -- The same goes for pkg-config constraints.-      (Simple (LDep _ (Ext  _))   _, _) -> return ()-      (Simple (LDep _ (Lang _))   _, _) -> return ()-      (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()--    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)-    requalify deps = do-      vs <- get-      return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)--pickFlag :: QFN -> Bool -> UpdateState ()-pickFlag qfn b = do-    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }-    verifyFlag qfn-    linkNewDeps (F qfn) b--pickStanza :: QSN -> Bool -> UpdateState ()-pickStanza qsn b = do-    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }-    verifyStanza qsn-    linkNewDeps (S qsn) b---- | Link dependencies that we discover after making a flag or stanza choice.------ When we make a flag choice for a package, then new dependencies for that--- package might become available. If the package under consideration is in a--- non-trivial link group, then these new dependencies have to be linked as--- well. In linkNewDeps, we compute such new dependencies and make sure they are--- linked.-linkNewDeps :: Var QPN -> Bool -> UpdateState ()-linkNewDeps var b = do-    vs <- get-    let qpn@(Q pp pn)           = varPN var-        qdeps                   = vsSaved vs ! qpn-        lg                      = vsLinks vs ! qpn-        newDeps                 = findNewDeps vs qdeps-        linkedTo                = S.delete pp (lgMembers lg)-    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps-  where-    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN-    findNewDeps vs = concatMap (findNewDeps' vs)--    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN-    findNewDeps' _  (Simple _ _)        = []-    findNewDeps' vs (Flagged qfn _ t f) =-      case (F qfn == var, M.lookup qfn (vsFlags vs)) of-        (True, _)    -> if b then t else f-        (_, Nothing) -> [] -- not yet known-        (_, Just b') -> findNewDeps vs (if b' then t else f)-    findNewDeps' vs (Stanza qsn t) =-      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of-        (True, _)    -> if b then t else []-        (_, Nothing) -> [] -- not yet known-        (_, Just b') -> findNewDeps vs (if b' then t else [])--updateLinkGroup :: LinkGroup -> UpdateState ()-updateLinkGroup lg = do-    verifyLinkGroup lg-    modify $ \vs -> vs {-        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))-                  `M.union` vsLinks vs-      }-  where-    aux pp = (Q pp (lgPackage lg), lg)--{--------------------------------------------------------------------------------  Verification--------------------------------------------------------------------------------}--verifyLinkGroup :: LinkGroup -> UpdateState ()-verifyLinkGroup lg =-    case lgInstance lg of-      -- No instance picked yet. Nothing to verify-      Nothing ->-        return ()--      -- We picked an instance. Verify flags and stanzas-      -- TODO: The enumeration of OptionalStanza names is very brittle;-      -- if a constructor is added to the datatype we won't notice it here-      Just i -> do-        vs <- get-        let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i-            flags   = M.keys finfo-            stanzas = [TestStanzas, BenchStanzas]-        forM_ flags $ \fn -> do-          let flag = FN (lgPackage lg) fn-          verifyFlag' flag lg-        forM_ stanzas $ \sn -> do-          let stanza = SN (lgPackage lg) sn-          verifyStanza' stanza lg--verifyFlag :: QFN -> UpdateState ()-verifyFlag (FN qpn@(Q _pp pn) fn) = do-    vs <- get-    -- We can only pick a flag after picking an instance; link group must exist-    verifyFlag' (FN pn fn) (vsLinks vs ! qpn)--verifyStanza :: QSN -> UpdateState ()-verifyStanza (SN qpn@(Q _pp pn) sn) = do-    vs <- get-    -- We can only pick a stanza after picking an instance; link group must exist-    verifyStanza' (SN pn sn) (vsLinks vs ! qpn)---- | Verify that all packages in the link group agree on flag assignments------ For the given flag and the link group, obtain all assignments for the flag--- that have already been made for link group members, and check that they are--- equal.-verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()-verifyFlag' (FN pn fn) lg = do-    vs <- get-    let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))-        vals  = map (`M.lookup` vsFlags vs) flags-    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags-      then return ()-      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg-                    , "flag \"" ++ unFlagName fn ++ "\" incompatible"-                    )---- | Verify that all packages in the link group agree on stanza assignments------ For the given stanza and the link group, obtain all assignments for the--- stanza that have already been made for link group members, and check that--- they are equal.------ This function closely mirrors 'verifyFlag''.-verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()-verifyStanza' (SN pn sn) lg = do-    vs <- get-    let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))-        vals    = map (`M.lookup` vsStanzas vs) stanzas-    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas-      then return ()-      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg-                    , "stanza \"" ++ showStanza sn ++ "\" incompatible"-                    )--{--------------------------------------------------------------------------------  Link groups--------------------------------------------------------------------------------}---- | Set of packages that must be linked together------ A LinkGroup is between several qualified package names. In the validation--- state, we maintain a map vsLinks from qualified package names to link groups.--- There is an invariant that for all members of a link group, vsLinks must map--- to the same link group. The function updateLinkGroup can be used to--- re-establish this invariant after creating or expanding a LinkGroup.-data LinkGroup = LinkGroup {-      -- | The name of the package of this link group-      lgPackage :: PN--      -- | The canonical member of this link group (the one where we picked-      -- a concrete instance). Once we have picked a canonical member, all-      -- other packages must link to this one.-      ---      -- We may not know this yet (if we are constructing link groups-      -- for dependencies)-    , lgCanon :: Maybe (PI PackagePath)--      -- | The members of the link group-    , lgMembers :: Set PackagePath--      -- | The set of variables that should be added to the conflict set if-      -- something goes wrong with this link set (in addition to the members-      -- of the link group itself)-    , lgBlame :: ConflictSet-    }-    deriving (Show, Eq)---- | Invariant for the set of link groups: every element in the link group--- must be pointing to the /same/ link group-lgInvariant :: Map QPN LinkGroup -> Bool-lgInvariant links = all invGroup (M.elems links)-  where-    invGroup :: LinkGroup -> Bool-    invGroup lg = allEqual $ map (`M.lookup` links) members-      where-        members :: [QPN]-        members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg)---- | Package version of this group------ This is only known once we have picked a canonical element.-lgInstance :: LinkGroup -> Maybe I-lgInstance = fmap (\(PI _ i) -> i) . lgCanon--showLinkGroup :: LinkGroup -> String-showLinkGroup lg =-    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"-  where-    showMember :: PackagePath -> String-    showMember pp = case lgCanon lg of-                      Just (PI pp' _i) | pp == pp' -> "*"-                      _otherwise                   -> ""-                 ++ case lgInstance lg of-                      Nothing -> showQPN (qpn pp)-                      Just i  -> showPI (PI (qpn pp) i)--    qpn :: PackagePath -> QPN-    qpn pp = Q pp (lgPackage lg)---- | Creates a link group that contains a single member.-lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup-lgSingleton (Q pp pn) canon = LinkGroup {-      lgPackage = pn-    , lgCanon   = canon-    , lgMembers = S.singleton pp-    , lgBlame   = CS.empty-    }--lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup-lgMerge blame lg lg' = do-    canon <- pick (lgCanon lg) (lgCanon lg')-    return LinkGroup {-        lgPackage = lgPackage lg-      , lgCanon   = canon-      , lgMembers = lgMembers lg `S.union` lgMembers lg'-      , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']-      }-  where-    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)-    pick Nothing  Nothing  = Right Nothing-    pick (Just x) Nothing  = Right $ Just x-    pick Nothing  (Just y) = Right $ Just y-    pick (Just x) (Just y) =-      if x == y then Right $ Just x-                else Left ( CS.unions [-                               blame-                             , lgConflictSet lg-                             , lgConflictSet lg'-                             ]-                          ,    "cannot merge " ++ showLinkGroup lg-                            ++ " and " ++ showLinkGroup lg'-                          )--lgConflictSet :: LinkGroup -> ConflictSet-lgConflictSet lg =-               CS.fromList (map aux (S.toList (lgMembers lg)))-    `CS.union` lgBlame lg-  where-    aux pp = P (Q pp (lgPackage lg))--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}--allEqual :: Eq a => [a] -> Bool-allEqual []       = True-allEqual [_]      = True-allEqual (x:y:ys) = x == y && allEqual (y:ys)
− Distribution/Solver/Modular/Log.hs 
@@ -1,31 +0,0 @@-module Distribution.Solver.Modular.Log-    ( displayLogMessages-    , SolverFailure(..)-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude--import Distribution.Solver.Types.Progress--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Message-import Distribution.Solver.Modular.RetryLog---- | Information about a dependency solver failure.-data SolverFailure =-    ExhaustiveSearch ConflictSet ConflictMap-  | BackjumpLimitReached---- | Postprocesses a log file. This function discards all log messages and--- avoids calling 'showMessages' if the log isn't needed (specified by--- 'keepLog'), for efficiency.-displayLogMessages :: Bool-                   -> RetryLog Message SolverFailure a-                   -> RetryLog String SolverFailure a-displayLogMessages keepLog lg = fromProgress $-    if keepLog-    then showMessages progress-    else foldProgress (const id) Fail Done progress-  where-    progress = toProgress lg
− Distribution/Solver/Modular/Message.hs 
@@ -1,271 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Distribution.Solver.Modular.Message (-    Message(..),-    showMessages-  ) where--import qualified Data.List as L-import Data.Map (Map)-import qualified Data.Map as M-import Data.Set (Set)-import qualified Data.Set as S-import Data.Maybe (catMaybes, mapMaybe)-import Prelude hiding (pi)--import Distribution.Pretty (prettyShow) -- from Cabal--import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-         ( FailReason(..), POption(..), ConflictingDep(..) )-import Distribution.Solver.Modular.Version-import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Progress-import Distribution.Types.LibraryName-import Distribution.Types.UnqualComponentName--data Message =-    Enter           -- ^ increase indentation level-  | Leave           -- ^ decrease indentation level-  | TryP QPN POption-  | TryF QFN Bool-  | TryS QSN Bool-  | Next (Goal QPN)-  | Skip (Set CS.Conflict)-  | Success-  | Failure ConflictSet FailReason---- | Transforms the structured message type to actual messages (strings).------ The log contains level numbers, which are useful for any trace that involves--- backtracking, because only the level numbers will allow to keep track of--- backjumps.-showMessages :: Progress Message a b -> Progress String a b-showMessages = go 0-  where-    -- 'go' increments the level for a recursive call when it encounters-    -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.-    go :: Int -> Progress Message a b -> Progress String a b-    go !_ (Done x)                           = Done x-    go !_ (Fail x)                           = Fail x-    -- complex patterns-    go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        goPReject l qpn [i] c fr ms-    go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =-        goPSkip l qpn [i] conflicts ms-    go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)-    go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)-    go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)-    go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =-        (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms-    -- standard display-    go !l (Step Enter                    ms) = go (l+1) ms-    go !l (Step Leave                    ms) = go (l-1) ms-    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)-    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)-    go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log-    go !l (Step (Skip conflicts)         ms) =-        -- 'Skip' should always be handled by 'goPSkip' in the case above.-        (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)-    go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)-    go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)--    showPackageGoal :: QPN -> QGoalReason -> String-    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr--    showFailure :: ConflictSet -> FailReason -> String-    showFailure c fr = "fail" ++ showFR c fr--    -- special handler for many subsequent package rejections-    goPReject :: Int-              -> QPN-              -> [POption]-              -> ConflictSet-              -> FailReason-              -> Progress Message a b-              -> Progress String a b-    goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))-      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms-    goPReject l qpn is c fr ms =-        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)--    -- Handle many subsequent skipped package instances.-    goPSkip :: Int-            -> QPN-            -> [POption]-            -> Set CS.Conflict-            -> Progress Message a b-            -> Progress String a b-    goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))-      | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms-    goPSkip l qpn is conflicts ms =-      let msg = "skipping: "-                 ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))-                 ++ showConflicts conflicts-      in atLevel l msg (go l ms)--    -- write a message with the current level number-    atLevel :: Int -> String -> Progress String a b -> Progress String a b-    atLevel l x xs =-      let s = show l-      in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs---- | Display the set of 'Conflicts' for a skipped package version.-showConflicts :: Set CS.Conflict -> String-showConflicts conflicts =-    " (has the same characteristics that caused the previous version to fail: "-     ++ conflictMsg ++ ")"-  where-    conflictMsg :: String-    conflictMsg =-      if S.member CS.OtherConflict conflicts-      then-        -- This case shouldn't happen, because an unknown conflict should not-        -- cause a version to be skipped.-        "unknown conflict"-      else let mergedConflicts =-                   [ showConflict qpn conflict-                   | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ]-           in if L.null mergedConflicts-              then-                  -- This case shouldn't happen unless backjumping is turned off.-                  "none"-              else L.intercalate "; " mergedConflicts--    -- Merge conflicts to simplify the log message.-    mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict-    mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList-      where-        mergeConflict :: MergedPackageConflict-                      -> MergedPackageConflict-                      -> MergedPackageConflict-        mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict {-              isGoalConflict =-                  isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2-            , versionConstraintConflict =-                  L.nub $ versionConstraintConflict mergedConflict1-                       ++ versionConstraintConflict mergedConflict2-            , versionConflict =-                  mergeVersionConflicts (versionConflict mergedConflict1)-                                        (versionConflict mergedConflict2)-            }-          where-            mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2)-            mergeVersionConflicts (Just vr1) Nothing    = Just vr1-            mergeVersionConflicts Nothing    (Just vr2) = Just vr2-            mergeVersionConflicts Nothing    Nothing    = Nothing--        toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict)-        toMergedConflict (CS.GoalConflict qpn) =-            Just (qpn, MergedPackageConflict True [] Nothing)-        toMergedConflict (CS.VersionConstraintConflict qpn v) =-            Just (qpn, MergedPackageConflict False [v] Nothing)-        toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =-            Just (qpn, MergedPackageConflict False [] (Just vr))-        toMergedConflict CS.OtherConflict = Nothing--    showConflict :: QPN -> MergedPackageConflict -> String-    showConflict qpn mergedConflict = L.intercalate "; " conflictStrings-      where-        conflictStrings = catMaybes [-            case () of-              () | isGoalConflict mergedConflict -> Just $-                     "depends on '" ++ showQPN qpn ++ "'" ++-                         (if null (versionConstraintConflict mergedConflict)-                          then ""-                          else " but excludes "-                                ++ showVersions (versionConstraintConflict mergedConflict))-                 | not $ L.null (versionConstraintConflict mergedConflict) -> Just $-                     "excludes '" ++ showQPN qpn-                      ++ "' " ++ showVersions (versionConstraintConflict mergedConflict)-                 | otherwise -> Nothing-          , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'")-             <$> versionConflict mergedConflict-          ]--        showVersions []  = "no versions"-        showVersions [v] = "version " ++ showVer v-        showVersions vs  = "versions " ++ L.intercalate ", " (map showVer vs)---- | All conflicts related to one package, used for simplifying the display of--- a 'Set CS.Conflict'.-data MergedPackageConflict = MergedPackageConflict {-    isGoalConflict :: Bool-  , versionConstraintConflict :: [Ver]-  , versionConflict :: Maybe VR-  }--showQPNPOpt :: QPN -> POption -> String-showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =-  case linkedTo of-    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption-    Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)--showGR :: QGoalReason -> String-showGR UserGoal            = " (user goal)"-showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"--showFR :: ConflictSet -> FailReason -> String-showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ prettyShow ext ++ ")"-showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ prettyShow lang ++ ")"-showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)"-showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"-showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"-showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"-showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")"-showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")"-showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"-showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"-showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)"-showFR _ CannotInstall                    = " (only already installed instances can be used)"-showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"-showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"-showFR _ Shadowed                         = " (shadowed by another installed package with same version)"-showFR _ (Broken u)                       = " (package is broken, missing depenedency " ++ prettyShow u ++ ")"-showFR _ UnknownPackage                   = " (unknown package)"-showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"-showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"-showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"-showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"-showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"-showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"-showFR _ MultipleInstances                = " (multiple instances)"-showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"-showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"-showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ prettyShow ver ++ ")"--- The following are internal failures. They should not occur. In the--- interest of not crashing unnecessarily, we still just print an error--- message though.-showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"-showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"-showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"--showExposedComponent :: ExposedComponent -> String-showExposedComponent (ExposedLib LMainLibName)       = "library"-showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"-showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"--constraintSource :: ConstraintSource -> String-constraintSource src = "constraint from " ++ showConstraintSource src--showConflictingDep :: ConflictingDep -> String-showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =-  let DependencyReason qpn' _ _ = dr-      componentStr = case comp of-                       ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"-                       ExposedLib LMainLibName      -> ""-                       ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"-  in case ci of-       Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++-                         showQPN qpn ++ componentStr ++ "==" ++ showI i-       Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++-                         componentStr ++ showVR vr
− Distribution/Solver/Modular/PSQ.hs 
@@ -1,149 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Solver.Modular.PSQ-    ( PSQ(..)  -- Unit test needs constructor access-    , casePSQ-    , cons-    , length-    , lookup-    , filter-    , filterIfAny-    , filterIfAnyByKeys-    , filterKeys-    , firstOnly-    , fromList-    , isZeroOrOne-    , keys-    , map-    , mapKeys-    , mapWithKey-    , maximumBy-    , minimumBy-    , null-    , prefer-    , preferByKeys-    , snoc-    , sortBy-    , sortByKeys-    , toList-    , union-    ) where---- Priority search queues.------ 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.--import Control.Arrow (first, second)--import qualified Data.Foldable as F-import Data.Function-import qualified Data.List as S-import Data.Ord (comparing)-import Data.Traversable-import Prelude hiding (foldr, length, lookup, filter, null, map)--newtype PSQ k v = PSQ [(k, v)]-  deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP--keys :: PSQ k v -> [k]-keys (PSQ xs) = fmap fst xs--lookup :: Eq k => k -> PSQ k v -> Maybe v-lookup k (PSQ xs) = S.lookup k xs--map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2-map f (PSQ xs) = PSQ (fmap (second f) xs)--mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v-mapKeys f (PSQ xs) = PSQ (fmap (first f) xs)--mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b-mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)--fromList :: [(k, a)] -> PSQ k a-fromList = PSQ--cons :: k -> a -> PSQ k a -> PSQ k a-cons k x (PSQ xs) = PSQ ((k, x) : xs)--snoc :: PSQ k a -> k -> a -> PSQ k a-snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])--casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r-casePSQ (PSQ xs) n c =-  case xs of-    []          -> n-    (k, v) : ys -> c k v (PSQ ys)--sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a-sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)--sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a-sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)--maximumBy :: (k -> Int) -> PSQ k a -> (k, a)-maximumBy sel (PSQ xs) =-  S.minimumBy (flip (comparing (sel . fst))) xs--minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a-minimumBy sel (PSQ xs) =-  PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]---- | Sort the list so that values satisfying the predicate are first.-prefer :: (a -> Bool) -> PSQ k a -> PSQ k a-prefer p = sortBy $ flip (comparing p)---- | Sort the list so that keys satisfying the predicate are first.-preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-preferByKeys p = sortByKeys $ flip (comparing p)---- | Will partition the list according to the predicate. If--- there is any element that satisfies the precidate, then only--- the elements satisfying the predicate are returned.--- Otherwise, the rest is returned.----filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a-filterIfAny p (PSQ xs) =-  let-    (pro, con) = S.partition (p . snd) xs-  in-    if S.null pro then PSQ con else PSQ pro---- | Variant of 'filterIfAny' that takes a predicate on the keys--- rather than on the values.----filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-filterIfAnyByKeys p (PSQ xs) =-  let-    (pro, con) = S.partition (p . fst) xs-  in-    if S.null pro then PSQ con else PSQ pro--filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a-filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)--filter :: (a -> Bool) -> PSQ k a -> PSQ k a-filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)--length :: PSQ k a -> Int-length (PSQ xs) = S.length xs--null :: PSQ k a -> Bool-null (PSQ xs) = S.null xs--isZeroOrOne :: PSQ k a -> Bool-isZeroOrOne (PSQ [])  = True-isZeroOrOne (PSQ [_]) = True-isZeroOrOne _         = False--firstOnly :: PSQ k a -> PSQ k a-firstOnly (PSQ [])      = PSQ []-firstOnly (PSQ (x : _)) = PSQ [x]--toList :: PSQ k a -> [(k, a)]-toList (PSQ xs) = xs--union :: PSQ k a -> PSQ k a -> PSQ k a-union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys)
− Distribution/Solver/Modular/Package.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Solver.Modular.Package-  ( I(..)-  , Loc(..)-  , PackageId-  , PackageIdentifier(..)-  , PackageName, mkPackageName, unPackageName-  , PkgconfigName, mkPkgconfigName, unPkgconfigName-  , PI(..)-  , PN-  , QPV-  , instI-  , makeIndependent-  , primaryPP-  , setupPP-  , showI-  , showPI-  , unPN-  ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude--import Distribution.Package -- from Cabal-import Distribution.Pretty (prettyShow)--import Distribution.Solver.Modular.Version-import Distribution.Solver.Types.PackagePath---- | A package name.-type PN = PackageName---- | Unpacking a package name.-unPN :: PN -> String-unPN = unPackageName---- | Package version. A package name plus a version number.-type PV = PackageId---- | Qualified package version.-type QPV = Qualified PV---- | Package id. Currently just a black-box string.-type PId = UnitId---- | Location. Info about whether a package is installed or not, and where--- exactly it is located. For installed packages, uniquely identifies the--- package instance via its 'PId'.------ TODO: More information is needed about the repo.-data Loc = Inst PId | InRepo-  deriving (Eq, Ord, Show)---- | Instance. A version number and a location.-data I = I Ver Loc-  deriving (Eq, Ord, Show)---- | String representation of an instance.-showI :: I -> String-showI (I v InRepo)   = showVer v-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid-  where-    extractPackageAbiHash xs =-      case first reverse $ break (=='-') $ reverse (prettyShow xs) of-        (ys, []) -> ys-        (ys, _)  -> '-' : ys---- | Package instance. A package name and an instance.-data PI qpn = PI qpn I-  deriving (Eq, Ord, Show, Functor)---- | String representation of a package instance.-showPI :: PI QPN -> String-showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i--instI :: I -> Bool-instI (I _ (Inst _)) = True-instI _              = False---- | Is the package in the primary group of packages.  This is used to--- determine (1) if we should try to establish stanza preferences--- for this goal, and (2) whether or not a user specified @--constraint@--- should apply to this dependency (grep 'primaryPP' to see the--- use sites).  In particular this does not include packages pulled in--- as setup deps.----primaryPP :: PackagePath -> Bool-primaryPP (PackagePath _ns q) = go q-  where-    go QualToplevel    = True-    go (QualBase  _)   = True-    go (QualSetup _)   = False-    go (QualExe _ _)   = False---- | Is the package a dependency of a setup script.  This is used to--- establish whether or not certain constraints should apply to this--- dependency (grep 'setupPP' to see the use sites).----setupPP :: PackagePath -> Bool-setupPP (PackagePath _ns (QualSetup _)) = True-setupPP (PackagePath _ns _)         = False---- | Qualify a target package with its own name so that its dependencies are not--- required to be consistent with other targets.-makeIndependent :: PN -> QPN-makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn
− Distribution/Solver/Modular/Preference.hs 
@@ -1,481 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | Reordering or pruning the tree in order to prefer or make certain choices.-module Distribution.Solver.Modular.Preference-    ( avoidReinstalls-    , deferSetupChoices-    , deferWeakFlagChoices-    , enforceManualFlags-    , enforcePackageConstraints-    , enforceSingleInstanceRestriction-    , firstGoal-    , preferBaseGoalChoice-    , preferLinked-    , preferPackagePreferences-    , preferReallyEasyGoalChoices-    , requireInstalled-    , onlyConstrained-    , sortGoals-    , pruneAfterFirstSuccess-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude--import qualified Data.List as L-import qualified Data.Map as M-import Control.Monad.Trans.Reader (Reader, runReader, ask, local)--import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal--import Distribution.Solver.Types.Flag-import Distribution.Solver.Types.InstalledPreference-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackageConstraint-import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.Variable--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.PSQ as P-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.ConflictSet as CS-import qualified Distribution.Solver.Modular.WeightedPSQ as W---- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a--- list of weight-calculating functions in order to avoid sorting the package--- choices multiple times. Each function takes the package name, sorted list of--- children's versions, and package option. 'addWeights' prepends the new--- weights to the existing weights, which gives precedence to preferences that--- are applied later.-addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c-addWeights fs = trav go-  where-    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)-    go (PChoiceF qpn@(Q _ pn) rdm x cs) =-      let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs)-          weights k = [f pn sortedVersions k | f <- fs]--          elemsToWhnf :: [a] -> ()-          elemsToWhnf = foldr seq ()-      in  PChoiceF qpn rdm x-          -- Evaluate the children's versions before evaluating any of the-          -- subtrees, so that 'sortedVersions' doesn't hold onto all of the-          -- subtrees (referenced by cs) and cause a space leak.-          (elemsToWhnf sortedVersions `seq`-             W.mapWeightsWithKey (\k w -> weights k ++ w) cs)-    go x                            = x--addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c-addWeight f = addWeights [f]--version :: POption -> Ver-version (POption (I v _) _) = v---- | Prefer to link packages whenever possible.-preferLinked :: Tree d c -> Tree d c-preferLinked = addWeight (const (const linked))-  where-    linked (POption _ Nothing)  = 1-    linked (POption _ (Just _)) = 0---- Works by setting weights on choice nodes. Also applies stanza preferences.-preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c-preferPackagePreferences pcs =-    preferPackageStanzaPreferences pcs .-    addWeights [-          \pn _  opt -> preferred pn opt--        -- Note that we always rank installed before uninstalled, and later-        -- versions before earlier, but we can change the priority of the-        -- two orderings.-        , \pn vs opt -> case preference pn of-                          PreferInstalled -> installed opt-                          PreferLatest    -> latest vs opt-        , \pn vs opt -> case preference pn of-                          PreferInstalled -> latest vs opt-                          PreferLatest    -> installed opt-        ]-  where-    -- Prefer packages with higher version numbers over packages with-    -- lower version numbers.-    latest :: [Ver] -> POption -> Weight-    latest sortedVersions opt =-      let l = length sortedVersions-          index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions-      in  fromIntegral index / fromIntegral l--    preference :: PN -> InstalledPreference-    preference pn =-      let PackagePreferences _ ipref _ = pcs pn-      in  ipref--    -- | Prefer versions satisfying more preferred version ranges.-    preferred :: PN -> POption -> Weight-    preferred pn opt =-      let PackagePreferences vrs _ _ = pcs pn-      in fromIntegral . negate . L.length $-         L.filter (flip checkVR (version opt)) vrs--    -- Prefer installed packages over non-installed packages.-    installed :: POption -> Weight-    installed (POption (I _ (Inst _)) _) = 0-    installed _                          = 1---- | Traversal that tries to establish package stanza enable\/disable--- preferences. Works by reordering the branches of stanza choices.-preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c-preferPackageStanzaPreferences pcs = trav go-  where-    go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts)-      | primaryPP pp && enableStanzaPref pn s =-          -- move True case first to try enabling the stanza-          let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts-              weight k = if k then 0 else 1-          -- defer the choice by setting it to weak-          in  SChoiceF qsn rdm gr (WeakOrTrivial True) ts'-    go x = x--    enableStanzaPref :: PN -> OptionalStanza -> Bool-    enableStanzaPref pn s =-      let PackagePreferences _ _ spref = pcs pn-      in  s `elem` spref---- | Helper function that tries to enforce a single package constraint on a--- given instance for a P-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintP :: forall d c. QPN-                          -> ConflictSet-                          -> I-                          -> LabeledPackageConstraint-                          -> Tree d c-                          -> Tree d c-processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r =-    if constraintScopeMatches scope qpn-    then go i prop-    else r-  where-    go :: I -> PackageProperty -> Tree d c-    go (I v _) (PackagePropertyVersion vr)-        | checkVR vr v  = r-        | otherwise     = Fail c (GlobalConstraintVersion vr src)-    go _       PackagePropertyInstalled-        | instI i       = r-        | otherwise     = Fail c (GlobalConstraintInstalled src)-    go _       PackagePropertySource-        | not (instI i) = r-        | otherwise     = Fail c (GlobalConstraintSource src)-    go _       _        = r---- | Helper function that tries to enforce a single package constraint on a--- given flag setting for an F-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintF :: forall d c. QPN-                          -> Flag-                          -> ConflictSet-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree d c-                          -> Tree d c-processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =-    if constraintScopeMatches scope qpn-    then go prop-    else r-  where-    go :: PackageProperty -> Tree d c-    go (PackagePropertyFlags fa) =-        case lookupFlagAssignment f fa of-          Nothing            -> r-          Just b | b == b'   -> r-                 | otherwise -> Fail c (GlobalConstraintFlag src)-    go _                             = r---- | Helper function that tries to enforce a single package constraint on a--- given flag setting for an F-node. Translates the constraint into a--- tree-transformer that either leaves the subtree untouched, or replaces it--- with an appropriate failure node.-processPackageConstraintS :: forall d c. QPN-                          -> OptionalStanza-                          -> ConflictSet-                          -> Bool-                          -> LabeledPackageConstraint-                          -> Tree d c-                          -> Tree d c-processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =-    if constraintScopeMatches scope qpn-    then go prop-    else r-  where-    go :: PackageProperty -> Tree d c-    go (PackagePropertyStanzas ss) =-        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)-                                 else r-    go _                               = r---- | Traversal that tries to establish various kinds of user constraints. Works--- by selectively disabling choices that have been ruled out by global user--- constraints.-enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]-                          -> Tree d c-                          -> Tree d c-enforcePackageConstraints pcs = trav go-  where-    go (PChoiceF qpn@(Q _ pn) rdm gr                    ts) =-      let c = varToConflictSet (P qpn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc)-                                       id-                                       (M.findWithDefault [] pn pcs)-      in PChoiceF qpn rdm gr        (W.mapWithKey g ts)-    go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) =-      let c = varToConflictSet (F qfn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc)-                           id-                           (M.findWithDefault [] pn pcs)-      in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts)-    go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr   ts) =-      let c = varToConflictSet (S qsn)-          -- compose the transformation functions for each of the relevant constraint-          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc)-                           id-                           (M.findWithDefault [] pn pcs)-      in SChoiceF qsn rdm gr tr     (W.mapWithKey g ts)-    go x = x---- | Transformation that tries to enforce the rule that manual flags can only be--- set by the user.------ If there are no constraints on a manual flag, this function prunes all but--- the default value. If there are constraints, then the flag is allowed to have--- the values specified by the constraints. Note that the type used for flag--- values doesn't need to be Bool.------ This function makes an exception for the case where there are multiple goals--- for a single package (with different qualifiers), and flag constraints for--- manual flag x only apply to some of those goals. In that case, we allow the--- unconstrained goals to use the default value for x OR any of the values in--- the constraints on x (even though the constraints don't apply), in order to--- allow the unconstrained goals to be linked to the constrained goals. See--- https://github.com/haskell/cabal/issues/4299. Removing the single instance--- restriction (SIR) would also fix #4299, so we may want to remove this--- exception and only let the user toggle manual flags if we remove the SIR.------ This function does not enforce any of the constraints, since that is done by--- 'enforcePackageConstraints'.-enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c-enforceManualFlags pcs = trav go-  where-    go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =-        FChoiceF qfn rdm gr tr Manual d $-          let -- A list of all values specified by constraints on 'fn'.-              -- We ignore the constraint scope in order to handle issue #4299.-              flagConstraintValues :: [Bool]-              flagConstraintValues =-                  [ flagVal-                  | let lpcs = M.findWithDefault [] pn pcs-                  , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs-                  , (fn', flagVal) <- unFlagAssignment fa-                  , fn' == fn ]--              -- Prune flag values that are not the default and do not match any-              -- of the constraints.-              restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c-              restrictToggling flagDefault constraintVals flagVal r =-                  if flagVal `elem` constraintVals || flagVal == flagDefault-                  then r-                  else Fail (varToConflictSet (F qfn)) ManualFlag--      in W.mapWithKey (restrictToggling d flagConstraintValues) ts-    go x                                                            = x---- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c-requireInstalled p = trav go-  where-    go (PChoiceF v@(Q _ pn) rdm gr cs)-      | p pn      = PChoiceF v rdm gr (W.mapWithKey installed cs)-      | otherwise = PChoiceF v rdm gr                         cs-      where-        installed (POption (I _ (Inst _)) _) x = x-        installed _ _ = Fail (varToConflictSet (P v)) CannotInstall-    go x          = x---- | Avoid reinstalls.------ This is a tricky strategy. If a package version is installed already and the--- same version is available from a repo, the repo version will never be chosen.--- This would result in a reinstall (either destructively, or potentially,--- shadowing). The old instance won't be visible or even present anymore, but--- other packages might have depended on it.------ TODO: It would be better to actually check the reverse dependencies of installed--- packages. If they're not depended on, then reinstalling should be fine. Even if--- they are, perhaps this should just result in trying to reinstall those other--- packages as well. However, doing this all neatly in one pass would require to--- change the builder, or at least to change the goal set after building.-avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c-avoidReinstalls p = trav go-  where-    go (PChoiceF qpn@(Q _ pn) rdm gr cs)-      | p pn      = PChoiceF qpn rdm gr disableReinstalls-      | otherwise = PChoiceF qpn rdm gr cs-      where-        disableReinstalls =-          let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]-          in  W.mapWithKey (notReinstall installed) cs--        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =-          Fail (varToConflictSet (P qpn)) CannotReinstall-        notReinstall _ _ x =-          x-    go x          = x---- | Require all packages to be mentioned in a constraint or as a goal.-onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason-onlyConstrained p = trav go-  where-    go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn)-      = FailF-        (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr)-        NotExplicit-    go x-      = x---- | Sort all goals using the provided function.-sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c-sortGoals variableOrder = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs)-    go x                    = x--    goalOrder :: Goal QPN -> Goal QPN -> Ordering-    goalOrder = variableOrder `on` (varToVariable . goalToVar)--    varToVariable :: Var QPN -> Variable QPN-    varToVariable (P qpn)                    = PackageVar qpn-    varToVariable (F (FN qpn fn))     = FlagVar qpn fn-    varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza---- | Reduce the branching degree of the search tree by removing all choices--- after the first successful choice at each level. The returned tree is the--- minimal subtree containing the path to the first backjump.-pruneAfterFirstSuccess :: Tree d c -> Tree d c-pruneAfterFirstSuccess = trav go-  where-    go (PChoiceF qpn rdm gr       ts) = PChoiceF qpn rdm gr       (W.takeUntil active ts)-    go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts)-    go (SChoiceF qsn rdm gr w     ts) = SChoiceF qsn rdm gr w     (W.takeUntil active ts)-    go x                              = x---- | Always choose the first goal in the list next, abandoning all--- other choices.------ This is unnecessary for the default search strategy, because--- it descends only into the first goal choice anyway,--- but may still make sense to just reduce the tree size a bit.-firstGoal :: Tree d c -> Tree d c-firstGoal = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs)-    go x                    = x-    -- Note that we keep empty choice nodes, because they mean success.---- | Transformation that tries to make a decision on base as early as--- possible by pruning all other goals when base is available. In nearly--- all cases, there's a single choice for the base package. Also, fixing--- base early should lead to better error messages.-preferBaseGoalChoice :: Tree d c -> Tree d c-preferBaseGoalChoice = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs)-    go x                    = x--    isBase :: Goal QPN -> Bool-    isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base"-    isBase _                       = False---- | Deal with setup dependencies after regular dependencies, so that we can--- will link setup dependencies against package dependencies when possible-deferSetupChoices :: Tree d c -> Tree d c-deferSetupChoices = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs)-    go x                    = x--    noSetup :: Goal QPN -> Bool-    noSetup (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False-    noSetup _                                                  = True---- | 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 d c -> Tree d c-deferWeakFlagChoices = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs))-    go x                    = x--    noWeakStanza :: Tree d c -> Bool-    noWeakStanza (SChoice _ _ _ (WeakOrTrivial True)   _) = False-    noWeakStanza _                                        = True--    noWeakFlag :: Tree d c -> Bool-    noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False-    noWeakFlag _                                          = True---- | Transformation that prefers goals with lower branching degrees.------ When a goal choice node has at least one goal with zero or one children, this--- function prunes all other goals. This transformation can help the solver find--- a solution in fewer steps by allowing it to backtrack sooner when it is--- exploring a subtree with no solutions. However, each step is more expensive.-preferReallyEasyGoalChoices :: Tree d c -> Tree d c-preferReallyEasyGoalChoices = trav go-  where-    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs)-    go x                    = x---- | Monad used internally in enforceSingleInstanceRestriction------ For each package instance we record the goal for which we picked a concrete--- instance. The SIR means that for any package instance there can only be one.-type EnforceSIR = Reader (Map (PI PN) QPN)---- | Enforce ghc's single instance restriction------ From the solver's perspective, this means that for any package instance--- (that is, package name + package version) there can be at most one qualified--- goal resolving to that instance (there may be other goals _linking_ to that--- instance however).-enforceSingleInstanceRestriction :: Tree d c -> Tree d c-enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go-  where-    go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c)--    -- We just verify package choices.-    go (PChoiceF qpn rdm gr cs) =-      PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs)-    go _otherwise =-      innM _otherwise--    -- The check proper-    goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)-    goP qpn@(Q _ pn) (POption i linkedTo) r = do-      let inst = PI pn i-      env <- ask-      case (linkedTo, M.lookup inst env) of-        (Just _, _) ->-          -- For linked nodes we don't check anything-          r-        (Nothing, Nothing) ->-          -- Not linked, not already used-          local (M.insert inst qpn) r-        (Nothing, Just qpn') -> do-          -- Not linked, already used. This is an error-          return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances
− Distribution/Solver/Modular/RetryLog.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Distribution.Solver.Modular.RetryLog-    ( RetryLog-    , toProgress-    , fromProgress-    , mapFailure-    , retry-    , failWith-    , succeedWith-    , continueWith-    , tryWith-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Solver.Modular.Message-import Distribution.Solver.Types.Progress---- | 'Progress' as a difference list that allows efficient appends at failures.-newtype RetryLog step fail done = RetryLog {-    unRetryLog :: forall fail2 . (fail -> Progress step fail2 done)-               -> Progress step fail2 done-  }---- | /O(1)/. Convert a 'RetryLog' to a 'Progress'.-toProgress :: RetryLog step fail done -> Progress step fail done-toProgress (RetryLog f) = f Fail---- | /O(N)/. Convert a 'Progress' to a 'RetryLog'.-fromProgress :: Progress step fail done -> RetryLog step fail done-fromProgress l = RetryLog $ \f -> go f l-  where-    go :: (fail1 -> Progress step fail2 done)-       -> Progress step fail1 done-       -> Progress step fail2 done-    go _ (Done d) = Done d-    go f (Fail failure) = f failure-    go f (Step m ms) = Step m (go f ms)---- | /O(1)/. Apply a function to the failure value in a log.-mapFailure :: (fail1 -> fail2)-           -> RetryLog step fail1 done-           -> RetryLog step fail2 done-mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure)---- | /O(1)/. If the first log leads to failure, continue with the second.-retry :: RetryLog step fail1 done-      -> (fail1 -> RetryLog step fail2 done)-      -> RetryLog step fail2 done-retry (RetryLog f) g =-    RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog---- | /O(1)/. Create a log with one message before a failure.-failWith :: step -> fail -> RetryLog step fail done-failWith m failure = RetryLog $ \f -> Step m (f failure)---- | /O(1)/. Create a log with one message before a success.-succeedWith :: step -> done -> RetryLog step fail done-succeedWith m d = RetryLog $ const $ Step m (Done d)---- | /O(1)/. Prepend a message to a log.-continueWith :: step-             -> RetryLog step fail done-             -> RetryLog step fail done-continueWith m (RetryLog f) = RetryLog $ Step m . f---- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert--- 'Leave' before the failure if the log fails.-tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done-tryWith m f =-  RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave))
− Distribution/Solver/Modular/Solver.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef DEBUG_TRACETREE-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif-module Distribution.Solver.Modular.Solver-    ( SolverConfig(..)-    , solve-    , PruneAfterFirstSuccess(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Data.Map as M-import qualified Data.List as L-import qualified Data.Set as S-import Distribution.Verbosity--import Distribution.Compiler (CompilerInfo)--import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)-import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.Settings-import Distribution.Solver.Types.Variable--import Distribution.Solver.Modular.Assignment-import Distribution.Solver.Modular.Builder-import Distribution.Solver.Modular.Cycles-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Explore-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Log-import Distribution.Solver.Modular.Message-import Distribution.Solver.Modular.Package-import qualified Distribution.Solver.Modular.Preference as P-import Distribution.Solver.Modular.Validate-import Distribution.Solver.Modular.Linking-import Distribution.Solver.Modular.PSQ (PSQ)-import Distribution.Solver.Modular.RetryLog-import Distribution.Solver.Modular.Tree-import qualified Distribution.Solver.Modular.PSQ as PSQ--import Distribution.Simple.Setup (BooleanFlag(..))--#ifdef DEBUG_TRACETREE-import qualified Distribution.Solver.Modular.ConflictSet as CS-import qualified Distribution.Solver.Modular.WeightedPSQ as W-import qualified Distribution.Deprecated.Text as T--import Debug.Trace.Tree (gtraceJson)-import Debug.Trace.Tree.Simple-import Debug.Trace.Tree.Generic-import Debug.Trace.Tree.Assoc (Assoc(..))-#endif---- | Various options for the modular solver.-data SolverConfig = SolverConfig {-  reorderGoals           :: ReorderGoals,-  countConflicts         :: CountConflicts,-  fineGrainedConflicts   :: FineGrainedConflicts,-  minimizeConflictSet    :: MinimizeConflictSet,-  independentGoals       :: IndependentGoals,-  avoidReinstalls        :: AvoidReinstalls,-  shadowPkgs             :: ShadowPkgs,-  strongFlags            :: StrongFlags,-  allowBootLibInstalls   :: AllowBootLibInstalls,-  onlyConstrained        :: OnlyConstrained,-  maxBackjumps           :: Maybe Int,-  enableBackjumping      :: EnableBackjumping,-  solveExecutables       :: SolveExecutables,-  goalOrder              :: Maybe (Variable QPN -> Variable QPN -> Ordering),-  solverVerbosity        :: Verbosity,-  pruneAfterFirstSuccess :: PruneAfterFirstSuccess-}---- | Whether to remove all choices after the first successful choice at each--- level in the search tree.-newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool---- | Run all solver phases.------ In principle, we have a valid tree after 'validationPhase', which--- means that every 'Done' node should correspond to valid solution.------ There is one exception, though, and that is cycle detection, which--- has been added relatively recently. Cycles are only removed directly--- before exploration.----solve :: SolverConfig                         -- ^ solver parameters-      -> CompilerInfo-      -> Index                                -- ^ all available packages as an index-      -> PkgConfigDb                          -- ^ available pkg-config pkgs-      -> (PN -> PackagePreferences)           -- ^ preferences-      -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints-      -> S.Set PN                             -- ^ global goals-      -> RetryLog Message SolverFailure (Assignment, RevDepMap)-solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =-  explorePhase     $-  detectCycles     $-  heuristicsPhase  $-  preferencesPhase $-  validationPhase  $-  prunePhase       $-  buildPhase-  where-    explorePhase     = backjumpAndExplore (maxBackjumps sc)-                                          (enableBackjumping sc)-                                          (fineGrainedConflicts sc)-                                          (countConflicts sc)-                                          idx-    detectCycles     = traceTree "cycles.json" id . detectCyclesPhase-    heuristicsPhase  =-      let heuristicsTree = traceTree "heuristics.json" id-          sortGoals = case goalOrder sc of-                        Nothing -> goalChoiceHeuristics .-                                   heuristicsTree .-                                   P.deferSetupChoices .-                                   P.deferWeakFlagChoices .-                                   P.preferBaseGoalChoice-                        Just order -> P.firstGoal .-                                   heuristicsTree .-                                   P.sortGoals order-          PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc-      in sortGoals .-         (if prune then P.pruneAfterFirstSuccess else id)-    preferencesPhase = P.preferLinked .-                       P.preferPackagePreferences userPrefs-    validationPhase  = traceTree "validated.json" id .-                       P.enforcePackageConstraints userConstraints .-                       P.enforceManualFlags userConstraints .-                       P.enforceSingleInstanceRestriction .-                       validateLinking idx .-                       validateTree cinfo idx pkgConfigDB-    prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .-                       (if asBool (allowBootLibInstalls sc)-                        then id-                        else P.requireInstalled (`elem` nonInstallable)) .-                       (case onlyConstrained sc of-                          OnlyConstrainedAll ->-                            P.onlyConstrained pkgIsExplicit-                          OnlyConstrainedNone ->-                            id)-    buildPhase       = traceTree "build.json" id-                     $ buildTree idx (independentGoals sc) (S.toList userGoals)--    allExplicit = M.keysSet userConstraints `S.union` userGoals--    pkgIsExplicit :: PN -> Bool-    pkgIsExplicit pn = S.member pn allExplicit--    -- packages that can never be installed or upgraded-    -- If you change this enumeration, make sure to update the list in-    -- "Distribution.Client.Dependency" as well-    nonInstallable :: [PackageName]-    nonInstallable =-        L.map mkPackageName-             [ "base"-             , "ghc-prim"-             , "integer-gmp"-             , "integer-simple"-             , "template-haskell"-             ]--    -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which-    -- prefers (keeps) goals only if the have 0 or 1 enabled choice.-    ---    -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes-    -- to just a single option. This was a way to work around a space leak that was-    -- unnecessary and is now fixed, so we no longer do it.-    ---    -- If --count-conflicts is active, it will then choose among the remaining goals-    -- the one that has been responsible for the most conflicts so far.-    ---    -- Otherwise, we simply choose the first remaining goal.-    ---    goalChoiceHeuristics-      | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices-      | otherwise                = id {- P.firstGoal -}---- | Dump solver tree to a file (in debugging mode)------ This only does something if the @debug-tracetree@ configure argument was--- given; otherwise this is just the identity function.-traceTree ::-#ifdef DEBUG_TRACETREE-  GSimpleTree a =>-#endif-     FilePath  -- ^ Output file-  -> (a -> a)  -- ^ Function to summarize the tree before dumping-  -> a -> a-#ifdef DEBUG_TRACETREE-traceTree = gtraceJson-#else-traceTree _ _ = id-#endif--#ifdef DEBUG_TRACETREE-instance GSimpleTree (Tree d c) where-  fromGeneric = go-    where-      go :: Tree d c -> SimpleTree-      go (PChoice qpn _ _       psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList  psq-      go (FChoice _   _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq-      go (SChoice _   _ _ _     psq) = Node "S" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq-      go (GoalChoice  _         psq) = Node "G" $ Assoc $ L.map (uncurry goG)       $ PSQ.toList psq-      go (Done _rdm _s)              = Node "D" $ Assoc []-      go (Fail cs _reason)           = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]--      psqToList :: W.WeightedPSQ w k v -> [(k, v)]-      psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList--      -- Show package choice-      goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)-      goP _        (POption (I ver _loc) Nothing)  subtree = (T.display ver, go subtree)-      goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)--      -- Show flag or stanza choice-      goFS :: Bool -> Tree d c -> (String, SimpleTree)-      goFS val subtree = (show val, go subtree)--      -- Show goal choice-      goG :: Goal QPN -> Tree d c -> (String, SimpleTree)-      goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)--      -- Variation on 'showGR' that produces shorter strings-      -- (Actually, QGoalReason records more info than necessary: we only need-      -- to know the variable that introduced the goal, not the value assigned-      -- to that variable)-      shortGR :: QGoalReason -> String-      shortGR UserGoal            = "user"-      shortGR (DependencyGoal dr) = showDependencyReason dr--      -- Show conflict set-      goCS :: ConflictSet -> String-      goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"-#endif---- | Replace all goal reasons with a dummy goal reason in the tree------ This is useful for debugging (when experimenting with the impact of GRs)-_removeGR :: Tree d c -> Tree d QGoalReason-_removeGR = trav go-  where-   go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)-   go (PChoiceF qpn rdm _       psq) = PChoiceF qpn rdm dummy       psq-   go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq-   go (SChoiceF qsn rdm _ a     psq) = SChoiceF qsn rdm dummy a     psq-   go (GoalChoiceF  rdm         psq) = GoalChoiceF  rdm             (goG psq)-   go (DoneF rdm s)                  = DoneF rdm s-   go (FailF cs reason)              = FailF cs reason--   goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)-   goG = PSQ.fromList-       . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))-       . PSQ.toList--   dummy :: QGoalReason-   dummy =-       DependencyGoal $-       DependencyReason-           (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))-           M.empty S.empty
− Distribution/Solver/Modular/Tree.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-module Distribution.Solver.Modular.Tree-    ( POption(..)-    , Tree(..)-    , TreeF(..)-    , Weight-    , FailReason(..)-    , ConflictingDep(..)-    , ana-    , cata-    , inn-    , innM-    , para-    , trav-    , zeroOrOneChoices-    , active-    ) where--import Control.Monad hiding (mapM, sequence)-import Data.Foldable-import Data.Traversable-import Prelude hiding (foldr, mapM, sequence)--import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.PSQ (PSQ)-import Distribution.Solver.Modular.Version-import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)-import qualified Distribution.Solver.Modular.WeightedPSQ as W-import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.Flag-import Distribution.Solver.Types.PackagePath-import Distribution.Types.PkgconfigVersionRange-import Distribution.Types.UnitId (UnitId)-import Language.Haskell.Extension (Extension, Language)--type Weight = Double---- | Type of the search tree. Inlining the choice nodes for now. Weights on--- package, flag, and stanza choices control the traversal order.------ The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes--- (type 'c'). For example, during the final traversal, choice nodes contain the--- variables that introduced the choices, and 'Done' nodes contain the--- assignments for all variables.------ TODO: The weight type should be changed from [Double] to Double to avoid--- giving too much weight to preferences that are applied later.-data Tree d c =-    -- | Choose a version for a package (or choose to link)-    PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c))--    -- | Choose a value for a flag-    ---    -- The Bool is the default value.-  | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c))--    -- | Choose whether or not to enable a stanza-  | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))--    -- | Choose which choice to make next-    ---    -- Invariants:-    ---    -- * PSQ should never be empty-    -- * For each choice we additionally record the 'QGoalReason' why we are-    --   introducing that goal into tree. Note that most of the time we are-    --   working with @Tree QGoalReason@; in that case, we must have the-    --   invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice'-    --   or 'SChoice' directly below a 'GoalChoice' node must equal the reason-    --   recorded on that 'GoalChoice' node.-  | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c))--    -- | We're done -- we found a solution!-  | Done RevDepMap d--    -- | We failed to find a solution in this path through the tree-  | Fail ConflictSet FailReason---- | A package option is a package instance with an optional linking annotation------ The modular solver has a number of package goals to solve for, and can only--- pick a single package version for a single goal. In order to allow to--- install multiple versions of the same package as part of a single solution--- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both--- be qualified goals for @P@, allowing to pick a difference version of package--- @P@ for @0.P@ and @1.P@.------ Linking is an essential part of this story. In addition to picking a specific--- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or--- vice versa). It means that @1.P@ and @0.P@ really must be the very same package--- (and hence must have the same build time configuration, and their--- dependencies must also be the exact same).------ See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.-data POption = POption I (Maybe PackagePath)-  deriving (Eq, Show)--data FailReason = UnsupportedExtension Extension-                | UnsupportedLanguage Language-                | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange-                | NewPackageDoesNotMatchExistingConstraint ConflictingDep-                | ConflictingConstraints ConflictingDep ConflictingDep-                | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)-                | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN)-                | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN)-                | PackageRequiresMissingComponent QPN ExposedComponent-                | PackageRequiresPrivateComponent QPN ExposedComponent-                | PackageRequiresUnbuildableComponent QPN ExposedComponent-                | CannotInstall-                | CannotReinstall-                | NotExplicit-                | Shadowed-                | Broken UnitId-                | UnknownPackage-                | GlobalConstraintVersion VR ConstraintSource-                | GlobalConstraintInstalled ConstraintSource-                | GlobalConstraintSource ConstraintSource-                | GlobalConstraintFlag ConstraintSource-                | ManualFlag-                | MalformedFlagChoice QFN-                | MalformedStanzaChoice QSN-                | EmptyGoalChoice-                | Backjump-                | MultipleInstances-                | DependenciesNotLinked String-                | CyclicDependencies-                | UnsupportedSpecVer Ver-  deriving (Eq, Show)---- | Information about a dependency involved in a conflict, for error messages.-data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI-  deriving (Eq, Show)---- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'--- have the same meaning as in 'Tree'.-data TreeF d c a =-    PChoiceF    QPN RevDepMap c                             (WeightedPSQ [Weight] POption a)-  | FChoiceF    QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool    a)-  | SChoiceF    QSN RevDepMap c WeakOrTrivial               (WeightedPSQ [Weight] Bool    a)-  | GoalChoiceF     RevDepMap                               (PSQ (Goal QPN) a)-  | DoneF           RevDepMap d-  | FailF       ConflictSet FailReason-  deriving (Functor, Foldable, Traversable)--out :: Tree d c -> TreeF d c (Tree d c)-out (PChoice    p s i       ts) = PChoiceF    p s i       ts-out (FChoice    p s i b m d ts) = FChoiceF    p s i b m d ts-out (SChoice    p s i b     ts) = SChoiceF    p s i b     ts-out (GoalChoice   s         ts) = GoalChoiceF   s         ts-out (Done       x s           ) = DoneF       x s-out (Fail       c x           ) = FailF       c x--inn :: TreeF d c (Tree d c) -> Tree d c-inn (PChoiceF    p s i       ts) = PChoice    p s i       ts-inn (FChoiceF    p s i b m d ts) = FChoice    p s i b m d ts-inn (SChoiceF    p s i b     ts) = SChoice    p s i b     ts-inn (GoalChoiceF   s         ts) = GoalChoice   s         ts-inn (DoneF       x s           ) = Done       x s-inn (FailF       c x           ) = Fail       c x--innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)-innM (PChoiceF    p s i       ts) = liftM (PChoice    p s i      ) (sequence ts)-innM (FChoiceF    p s i b m d ts) = liftM (FChoice    p s i b m d) (sequence ts)-innM (SChoiceF    p s i b     ts) = liftM (SChoice    p s i b    ) (sequence ts)-innM (GoalChoiceF   s         ts) = liftM (GoalChoice   s        ) (sequence ts)-innM (DoneF       x s           ) = return $ Done     x s-innM (FailF       c x           ) = return $ Fail     c x---- | Determines whether a tree is active, i.e., isn't a failure node.-active :: Tree d c -> Bool-active (Fail _ _) = False-active _          = True---- | Approximates the number of active choices that are available in a node.--- Note that we count goal choices as having one choice, always.-zeroOrOneChoices :: Tree d c -> Bool-zeroOrOneChoices (PChoice    _ _ _       ts) = W.isZeroOrOne (W.filter active ts)-zeroOrOneChoices (FChoice    _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)-zeroOrOneChoices (SChoice    _ _ _ _     ts) = W.isZeroOrOne (W.filter active ts)-zeroOrOneChoices (GoalChoice _           _ ) = True-zeroOrOneChoices (Done       _ _           ) = True-zeroOrOneChoices (Fail       _ _           ) = True---- | Catamorphism on trees.-cata :: (TreeF d c a -> a) -> Tree d c -> a-cata phi x = (phi . fmap (cata phi) . out) x--trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a-trav psi x = cata (inn . psi) x---- | Paramorphism on trees.-para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a-para phi = phi . fmap (\ x -> (para phi x, x)) . out---- | Anamorphism on trees.-ana :: (a -> TreeF d c a) -> a -> Tree d c-ana psi = inn . fmap (ana psi) . psi
− Distribution/Solver/Modular/Validate.hs 
@@ -1,593 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif-module Distribution.Solver.Modular.Validate (validateTree) where---- Validation of the tree.------ The task here is to make sure all constraints hold. After validation, any--- assignment returned by exploration of the tree should be a complete valid--- assignment, i.e., actually constitute a solution.--import Control.Applicative-import Control.Monad.Reader hiding (sequence)-import Data.Either (lefts)-import Data.Function (on)-import Data.Traversable-import Prelude hiding (sequence)--import qualified Data.List as L-import qualified Data.Set as S--import Language.Haskell.Extension (Extension, Language)--import Data.Map.Strict as M-import Distribution.Compiler (CompilerInfo(..))--import Distribution.Solver.Modular.Assignment-import qualified Distribution.Solver.Modular.ConflictSet as CS-import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag-import Distribution.Solver.Modular.Index-import Distribution.Solver.Modular.Package-import Distribution.Solver.Modular.Tree-import Distribution.Solver.Modular.Version-import qualified Distribution.Solver.Modular.WeightedPSQ as W--import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)-import Distribution.Types.LibraryName-import Distribution.Types.PkgconfigVersionRange--#ifdef DEBUG_CONFLICT_SETS-import GHC.Stack (CallStack)-#endif---- In practice, most constraints are implication constraints (IF we have made--- a number of choices, THEN we also have to ensure that). We call constraints--- that for which the preconditions are fulfilled ACTIVE. We maintain a set--- of currently active constraints that we pass down the node.------ We aim at detecting inconsistent states as early as possible.------ Whenever we make a choice, there are two things that need to happen:------   (1) We must check that the choice is consistent with the currently---       active constraints.------   (2) The choice increases the set of active constraints. For the new---       active constraints, we must check that they are consistent with---       the current state.------ We can actually merge (1) and (2) by saying the current choice is--- a new active constraint, fixing the choice.------ If a test fails, we have detected an inconsistent state. We can--- disable the current subtree and do not have to traverse it any further.------ We need a good way to represent the current state, i.e., the current--- set of active constraints. Since the main situation where we have to--- search in it is (1), it seems best to store the state by package: for--- every package, we store which versions are still allowed. If for any--- package, we have inconsistent active constraints, we can also stop.--- This is a particular way to read task (2):------   (2, weak) We only check if the new constraints are consistent with---       the choices we've already made, and add them to the active set.------   (2, strong) We check if the new constraints are consistent with the---       choices we've already made, and the constraints we already have.------ It currently seems as if we're implementing the weak variant. However,--- when used together with 'preferEasyGoalChoices', we will find an--- inconsistent state in the very next step.------ What do we do about flags?------ Like for packages, we store the flag choices we have already made.--- Now, regarding (1), we only have to test whether we've decided the--- current flag before. Regarding (2), the interesting bit is in discovering--- the new active constraints. To this end, we look up the constraints for--- the package the flag belongs to, and traverse its flagged dependencies.--- Wherever we find the flag in question, we start recording dependencies--- underneath as new active dependencies. If we encounter other flags, we--- check if we've chosen them already and either proceed or stop.---- | The state needed during validation.-data ValidateState = VS {-  supportedExt        :: Extension -> Bool,-  supportedLang       :: Language  -> Bool,-  presentPkgs         :: PkgconfigName -> PkgconfigVersionRange  -> Bool,-  index               :: Index,--  -- Saved, scoped, dependencies. Every time 'validate' makes a package choice,-  -- it qualifies the package's dependencies and saves them in this map. Then-  -- the qualified dependencies are available for subsequent flag and stanza-  -- choices for the same package.-  saved               :: Map QPN (FlaggedDeps QPN),--  pa                  :: PreAssignment,--  -- Map from package name to the components that are provided by the chosen-  -- instance of that package, and whether those components are visible and-  -- buildable.-  availableComponents :: Map QPN (Map ExposedComponent ComponentInfo),--  -- Map from package name to the components that are required from that-  -- package.-  requiredComponents  :: Map QPN ComponentDependencyReasons,--  qualifyOptions      :: QualifyOptions-}--newtype Validate a = Validate (Reader ValidateState a)-  deriving (Functor, Applicative, Monad, MonadReader ValidateState)--runValidate :: Validate a -> ValidateState -> a-runValidate (Validate r) = runReader r---- | A preassignment comprises knowledge about variables, but not--- necessarily fixed values.-data PreAssignment = PA PPreAssignment FAssignment SAssignment---- | A (partial) package preassignment. Qualified package names--- are associated with MergedPkgDeps.-type PPreAssignment = Map QPN MergedPkgDep---- | A dependency on a component, including its DependencyReason.-data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI---- | Map from component name to one of the reasons that the component is--- required.-type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN)---- | MergedPkgDep records constraints about the instances that can still be--- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a--- list of version ranges paired with the goals / variables that introduced--- them. It also records whether a package is a build-tool dependency, for each--- reason that it was introduced.------ It is important to store the component name with the version constraint, for--- error messages, because whether something is a build-tool dependency affects--- its qualifier, which affects which constraint is applied.-data MergedPkgDep =-    MergedDepFixed ExposedComponent (DependencyReason QPN) I-  | MergedDepConstrained [VROrigin]---- | Version ranges paired with origins.-type VROrigin = (VR, ExposedComponent, DependencyReason QPN)---- | The information needed to create a 'Fail' node.-type Conflict = (ConflictSet, FailReason)--validate :: Tree d c -> Validate (Tree d c)-validate = cata go-  where-    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)--    go (PChoiceF qpn rdm gr       ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts)-    go (FChoiceF qfn rdm gr b m d ts) =-      do-        -- Flag choices may occur repeatedly (because they can introduce new constraints-        -- in various places). However, subsequent choices must be consistent. We thereby-        -- collapse repeated flag choice nodes.-        PA _ pfa _ <- asks pa -- obtain current flag-preassignment-        case M.lookup qfn pfa of-          Just rb -> -- flag has already been assigned; collapse choice to the correct branch-                     case W.lookup rb ts of-                       Just t  -> goF qfn rb t-                       Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)-          Nothing -> -- flag choice is new, follow both branches-                     FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts)-    go (SChoiceF qsn rdm gr b   ts) =-      do-        -- Optional stanza choices are very similar to flag choices.-        PA _ _ psa <- asks pa -- obtain current stanza-preassignment-        case M.lookup qsn psa of-          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch-                     case W.lookup rb ts of-                       Just t  -> goS qsn rb t-                       Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)-          Nothing -> -- stanza choice is new, follow both branches-                     SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts)--    -- We don't need to do anything for goal choices or failure nodes.-    go (GoalChoiceF rdm           ts) = GoalChoice rdm <$> sequence ts-    go (DoneF       rdm s           ) = pure (Done rdm s)-    go (FailF    c fr               ) = pure (Fail c fr)--    -- What to do for package nodes ...-    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)-    goP qpn@(Q _pp pn) (POption i _) r = do-      PA ppa pfa psa <- asks pa    -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      idx            <- asks index -- obtain the index-      svd            <- asks saved -- obtain saved dependencies-      aComps         <- asks availableComponents-      rComps         <- asks requiredComponents-      qo             <- asks qualifyOptions-      -- obtain dependencies and index-dictated exclusions introduced by the choice-      let (PInfo deps comps _ mfr) = idx ! pn ! i-      -- qualify the deps in the current scope-      let qdeps = qualifyDeps qo qpn deps-      -- the new active constraints are given by the instance we have chosen,-      -- plus the dependency information we have for that instance-      let newactives = extractAllDeps pfa psa qdeps-      -- We now try to extend the partial assignment with the new active constraints.-      let mnppa = extend extSupported langSupported pkgPresent newactives-                   =<< extendWithPackageChoice (PI qpn i) ppa-      -- In case we continue, we save the scoped dependencies-      let nsvd = M.insert qpn qdeps svd-      case mfr of-        Just fr -> -- The index marks this as an invalid choice. We can stop.-                   return (Fail (varToConflictSet (P qpn)) fr)-        Nothing ->-          let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)-              newDeps = do-                nppa <- mnppa-                rComps' <- extendRequiredComponents qpn aComps rComps newactives-                checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps-                return (nppa, rComps')-          in case newDeps of-               Left (c, fr)          -> -- We have an inconsistency. We can stop.-                                        return (Fail c fr)-               Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation.-                                        local (\ s -> s { pa = PA nppa pfa psa-                                                        , saved = nsvd-                                                        , availableComponents = M.insert qpn comps aComps-                                                        , requiredComponents = rComps'-                                                        }) r--    -- What to do for flag nodes ...-    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goF qfn@(FN qpn _f) b r = do-      PA ppa pfa psa <- asks pa -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs-      svd            <- asks saved         -- obtain saved dependencies-      aComps         <- asks availableComponents-      rComps         <- asks requiredComponents-      -- Note that there should be saved dependencies for the package in question,-      -- because while building, we do not choose flags before we see the packages-      -- that define them.-      let qdeps = svd ! qpn-      -- We take the *saved* dependencies, because these have been qualified in the-      -- correct scope.-      ---      -- Extend the flag assignment-      let npfa = M.insert qfn b pfa-      -- We now try to get the new active dependencies we might learn about because-      -- we have chosen a new flag.-      let newactives = extractNewDeps (F qfn) b npfa psa qdeps-          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives-      -- As in the package case, we try to extend the partial assignment.-      let mnppa = extend extSupported langSupported pkgPresent newactives ppa-      case liftM2 (,) mnppa mNewRequiredComps of-        Left (c, fr)         -> return (Fail c fr) -- inconsistency found-        Right (nppa, rComps') ->-            local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r--    -- What to do for stanza nodes (similar to flag nodes) ...-    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)-    goS qsn@(SN qpn _f) b r = do-      PA ppa pfa psa <- asks pa -- obtain current preassignment-      extSupported   <- asks supportedExt  -- obtain the supported extensions-      langSupported  <- asks supportedLang -- obtain the supported languages-      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs-      svd            <- asks saved         -- obtain saved dependencies-      aComps         <- asks availableComponents-      rComps         <- asks requiredComponents-      -- Note that there should be saved dependencies for the package in question,-      -- because while building, we do not choose flags before we see the packages-      -- that define them.-      let qdeps = svd ! qpn-      -- We take the *saved* dependencies, because these have been qualified in the-      -- correct scope.-      ---      -- Extend the flag assignment-      let npsa = M.insert qsn b psa-      -- We now try to get the new active dependencies we might learn about because-      -- we have chosen a new flag.-      let newactives = extractNewDeps (S qsn) b pfa npsa qdeps-          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives-      -- As in the package case, we try to extend the partial assignment.-      let mnppa = extend extSupported langSupported pkgPresent newactives ppa-      case liftM2 (,) mnppa mNewRequiredComps of-        Left (c, fr)         -> return (Fail c fr) -- inconsistency found-        Right (nppa, rComps') ->-            local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r---- | Check that a newly chosen package instance contains all components that--- are required from that package so far. The components must also be visible--- and buildable.-checkComponentsInNewPackage :: ComponentDependencyReasons-                            -> QPN-                            -> Map ExposedComponent ComponentInfo-                            -> Either Conflict ()-checkComponentsInNewPackage required qpn providedComps =-    case M.toList $ deleteKeys (M.keys providedComps) required of-      (missingComp, dr) : _ ->-          Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent-      []                    ->-          let failures = lefts-                  [ case () of-                      _ | compIsVisible compInfo == IsVisible False ->-                          Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent-                        | compIsBuildable compInfo == IsBuildable False ->-                          Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent-                        | otherwise -> Right ()-                  | let merged = M.intersectionWith (,) required providedComps-                  , (comp, (dr, compInfo)) <- M.toList merged ]-          in case failures of-               failure : _ -> Left failure-               []          -> Right ()-  where-    mkConflict :: ExposedComponent-               -> DependencyReason QPN-               -> (ExposedComponent -> DependencyReason QPN -> FailReason)-               -> Conflict-    mkConflict comp dr mkFailure =-        (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr)--    deleteKeys :: Ord k => [k] -> Map k v -> Map k v-    deleteKeys ks m = L.foldr M.delete m ks---- | We try to extract as many concrete dependencies from the given flagged--- dependencies as possible. We make use of all the flag knowledge we have--- already acquired.-extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]-extractAllDeps fa sa deps = do-  d <- deps-  case d of-    Simple sd _         -> return sd-    Flagged qfn _ td fd -> case M.lookup qfn fa of-                             Nothing    -> mzero-                             Just True  -> extractAllDeps fa sa td-                             Just False -> extractAllDeps fa sa fd-    Stanza qsn td       -> case M.lookup qsn sa of-                             Nothing    -> mzero-                             Just True  -> extractAllDeps fa sa td-                             Just False -> []---- | We try to find new dependencies that become available due to the given--- flag or stanza choice. We therefore look for the choice in question, and then call--- 'extractAllDeps' for everything underneath.-extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]-extractNewDeps v b fa sa = go-  where-    go :: FlaggedDeps QPN -> [LDep QPN]-    go deps = do-      d <- deps-      case d of-        Simple _ _           -> mzero-        Flagged qfn' _ td fd-          | v == F qfn'      -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd-          | otherwise        -> case M.lookup qfn' fa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> go fd-        Stanza qsn' td-          | v == S qsn'      -> if b then extractAllDeps fa sa td else []-          | otherwise        -> case M.lookup qsn' sa of-                                  Nothing    -> mzero-                                  Just True  -> go td-                                  Just False -> []---- | Extend a package preassignment.------ Takes the variable that causes the new constraints, a current preassignment--- and a set of new dependency constraints.------ We're trying to extend the preassignment with each dependency one by one.--- Each dependency is for a particular variable. We check if we already have--- constraints for that variable in the current preassignment. If so, we're--- trying to merge the constraints.------ Either returns a witness of the conflict that would arise during the merge,--- or the successfully extended assignment.-extend :: (Extension -> Bool)            -- ^ is a given extension supported-       -> (Language  -> Bool)            -- ^ is a given language supported-       -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable-       -> [LDep QPN]-       -> PPreAssignment-       -> Either Conflict PPreAssignment-extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives-  where--    extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment-    extendSingle a (LDep dr (Ext  ext ))  =-      if extSupported  ext  then Right a-                            else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext)-    extendSingle a (LDep dr (Lang lang))  =-      if langSupported lang then Right a-                            else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang)-    extendSingle a (LDep dr (Pkg pn vr))  =-      if pkgPresent pn vr then Right a-                          else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr)-    extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) =-      let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a-      in  case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of-            Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')-            Right x           -> Right x---- | Extend a package preassignment with a package choice. For example, when--- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.------ TODO: The new constraint is implemented as a dependency from foo to foo's--- main library. That isn't correct, because foo might only be needed as a build--- tool dependency. The implemention may need to change when we support--- component-based dependency solving.-extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment-extendWithPackageChoice (PI qpn i) ppa =-  let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa-      newChoice = PkgDep (DependencyReason qpn M.empty S.empty)-                         (PkgComponent qpn (ExposedLib LMainLibName))-                         (Fixed i)-  in  case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of-        Left (c, (d, _d')) -> -- Don't include the package choice in the-                              -- FailReason, because it is redundant.-                              Left (c, NewPackageDoesNotMatchExistingConstraint d)-        Right x            -> Right x---- | Merge constrained instances. We currently adopt a lazy strategy for--- merging, i.e., we only perform actual checking if one of the two choices--- is fixed. If the merge fails, we return a conflict set indicating the--- variables responsible for the failure, as well as the two conflicting--- fragments.------ Note that while there may be more than one conflicting pair of version--- ranges, we only return the first we find.------ The ConflictingDeps are returned in order, i.e., the first describes the--- conflicting part of the MergedPkgDep, and the second describes the PkgDep.------ TODO: Different pairs might have different conflict sets. We're--- obviously interested to return a conflict that has a "better" conflict--- set in the sense the it contains variables that allow us to backjump--- further. We might apply some heuristics here, such as to change the--- order in which we check the constraints.-merge ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep-merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2))-  | i1 == i2  = Right $ MergedDepFixed comp1 vs1 i1-  | otherwise =-      Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2-           , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1)-             , ConflictingDep vs2 (PkgComponent p comp2) ci ) )--merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))-  | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i-  | otherwise    =-      Left ( createConflictSetForVersionConflict p v vs1 vr vs2-           , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i)-             , ConflictingDep vs2 (PkgComponent p comp2) ci ) )--merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) =-    go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...-  where-    go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep-    go [] = Right (MergedDepFixed comp2 vs2 i)-    go ((vr, comp1, vs1) : vros)-       | checkVR vr v = go vros-       | otherwise    =-           Left ( createConflictSetForVersionConflict p v vs2 vr vs1-                , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr)-                  , ConflictingDep vs2 (PkgComponent p comp2) ci ) )--merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) =-    Right (MergedDepConstrained $--    -- TODO: This line appends the new version range, to preserve the order used-    -- before a refactoring. Consider prepending the version range, if there is-    -- no negative performance impact.-    vrOrigins ++ [(vr, comp2, vs2)])---- | Creates a conflict set representing a conflict between a version constraint--- and the fixed version chosen for a package.-createConflictSetForVersionConflict :: QPN-                                    -> Ver-                                    -> DependencyReason QPN-                                    -> VR-                                    -> DependencyReason QPN-                                    -> ConflictSet-createConflictSetForVersionConflict pkg-                                    conflictingVersion-                                    versionDR@(DependencyReason p1 _ _)-                                    conflictingVersionRange-                                    versionRangeDR@(DependencyReason p2 _ _) =-  let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss)-  in-    -- The solver currently only optimizes the case where there is a conflict-    -- between the version chosen for a package and a version constraint that-    -- is not under any flags or stanzas. Here is how we check for this case:-    ---    --   (1) Choosing a specific version for a package foo is implemented as-    --       adding a dependency from foo to that version of foo (See-    --       extendWithPackageChoice), so we check that the DependencyReason-    --       contains the current package and no flag or stanza choices.-    ---    --   (2) We check that the DependencyReason for the version constraint also-    --       contains no flag or stanza choices.-    ---    -- When these criteria are not met, we fall back to calling-    -- dependencyReasonToConflictSet.-    if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR)-    then let cs1 = dependencyReasonToConflictSetWithVersionConflict-                   p2-                   (CS.OrderedVersionRange conflictingVersionRange)-                   versionDR-             cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict-                   pkg conflictingVersion versionRangeDR-         in cs1 `CS.union` cs2-    else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR---- | Takes a list of new dependencies and uses it to try to update the map of--- known component dependencies. It returns a failure when a new dependency--- requires a component that is missing, private, or unbuildable in a previously--- chosen package.-extendRequiredComponents :: QPN -- ^ package we extend-                         -> Map QPN (Map ExposedComponent ComponentInfo)-                         -> Map QPN ComponentDependencyReasons-                         -> [LDep QPN]-                         -> Either Conflict (Map QPN ComponentDependencyReasons)-extendRequiredComponents eqpn available = foldM extendSingle-  where-    extendSingle :: Map QPN ComponentDependencyReasons-                 -> LDep QPN-                 -> Either Conflict (Map QPN ComponentDependencyReasons)-    extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) =-      let compDeps = M.findWithDefault M.empty qpn required-          success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required-      in -- Only check for the existence of the component if its package has-         -- already been chosen.-         case M.lookup qpn available of-           Just comps ->-               case M.lookup comp comps of-                 Nothing ->-                     Left $ mkConflict qpn comp dr PackageRequiresMissingComponent-                 Just compInfo-                   | compIsVisible compInfo == IsVisible False-                   , eqpn /= qpn -- package components can depend on other components-                   ->-                     Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent-                   | compIsBuildable compInfo == IsBuildable False ->-                     Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent-                   | otherwise -> success-           Nothing    -> success-    extendSingle required _                                         = Right required--    mkConflict :: QPN-               -> ExposedComponent-               -> DependencyReason QPN-               -> (QPN -> ExposedComponent -> FailReason)-               -> Conflict-    mkConflict qpn comp dr mkFailure =-      (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp)----- | Interface.-validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c-validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {-    supportedExt        = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported-                                (\ es -> let s = S.fromList es in \ x -> S.member x s)-                                (compilerInfoExtensions cinfo)-  , supportedLang       = maybe (const True)-                                (flip L.elem) -- use list lookup because language list is small and no Ord instance-                                (compilerInfoLanguages  cinfo)-  , presentPkgs         = pkgConfigPkgIsPresent pkgConfigDb-  , index               = idx-  , saved               = M.empty-  , pa                  = PA M.empty M.empty M.empty-  , availableComponents = M.empty-  , requiredComponents  = M.empty-  , qualifyOptions      = defaultQualifyOptions idx-  }
− Distribution/Solver/Modular/Var.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Distribution.Solver.Modular.Var (-    Var(..)-  , showVar-  , varPN-  ) where--import Prelude hiding (pi)--import Distribution.Solver.Modular.Flag-import Distribution.Solver.Types.PackagePath--{--------------------------------------------------------------------------------  Variables--------------------------------------------------------------------------------}---- | The type of variables that play a role in the solver.--- Note that the tree currently does not use this type directly,--- and rather has separate tree nodes for the different types of--- variables. This fits better with the fact that in most cases,--- these have to be treated differently.-data Var qpn = P qpn | F (FN qpn) | S (SN qpn)-  deriving (Eq, Ord, Show, Functor)--showVar :: Var QPN -> String-showVar (P qpn) = showQPN qpn-showVar (F qfn) = showQFN qfn-showVar (S qsn) = showQSN qsn---- | Extract the package name from a Var-varPN :: Var qpn -> qpn-varPN (P qpn)        = qpn-varPN (F (FN qpn _)) = qpn-varPN (S (SN qpn _)) = qpn
− Distribution/Solver/Modular/Version.hs 
@@ -1,56 +0,0 @@-module Distribution.Solver.Modular.Version-    ( Ver-    , VR-    , anyVR-    , checkVR-    , eqVR-    , showVer-    , showVR-    , simplifyVR-    , (.&&.)-    , (.||.)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import qualified Distribution.Version as CV -- from Cabal-import Distribution.Pretty (prettyShow)---- | Preliminary type for versions.-type Ver = CV.Version---- | String representation of a version.-showVer :: Ver -> String-showVer = prettyShow---- | Version range. Consists of a lower and upper bound.-type VR = CV.VersionRange---- | String representation of a version range.-showVR :: VR -> String-showVR = prettyShow---- | Unconstrained version range.-anyVR :: VR-anyVR = CV.anyVersion---- | Version range fixing a single version.-eqVR :: Ver -> VR-eqVR = CV.thisVersion---- | Intersect two version ranges.-(.&&.) :: VR -> VR -> VR-v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2---- | Union of two version ranges.-(.||.) :: VR -> VR -> VR-v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2---- | Simplify a version range.-simplifyVR :: VR -> VR-simplifyVR = CV.simplifyVersionRange---- | Checking a version against a version range.-checkVR :: VR -> Ver -> Bool-checkVR = flip CV.withinRange
− Distribution/Solver/Modular/WeightedPSQ.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Distribution.Solver.Modular.WeightedPSQ (-    WeightedPSQ-  , fromList-  , toList-  , keys-  , weights-  , isZeroOrOne-  , filter-  , lookup-  , mapWithKey-  , mapWeightsWithKey-  , union-  , takeUntil-  ) where--import qualified Data.Foldable as F-import qualified Data.List as L-import Data.Ord (comparing)-import qualified Data.Traversable as T-import Prelude hiding (filter, lookup)---- | An association list that is sorted by weight.------ Each element has a key ('k'), value ('v'), and weight ('w'). All operations--- that add elements or modify weights stably sort the elements by weight.-newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)]-  deriving (Eq, Show, Functor, F.Foldable, T.Traversable)---- | /O(N)/.-filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v-filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs)---- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements.-isZeroOrOne :: WeightedPSQ w k v -> Bool-isZeroOrOne (WeightedPSQ [])  = True-isZeroOrOne (WeightedPSQ [_]) = True-isZeroOrOne _                 = False---- | /O(1)/. Return the elements in order.-toList :: WeightedPSQ w k v -> [(w, k, v)]-toList (WeightedPSQ xs) = xs---- | /O(N log N)/.-fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v-fromList = WeightedPSQ . L.sortBy (comparing triple_1)---- | /O(N)/. Return the weights in order.-weights :: WeightedPSQ w k v -> [w]-weights (WeightedPSQ xs) = L.map triple_1 xs---- | /O(N)/. Return the keys in order.-keys :: WeightedPSQ w k v -> [k]-keys (WeightedPSQ xs) = L.map triple_2 xs---- | /O(N)/. Return the value associated with the first occurrence of the give--- key, if it exists.-lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v-lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs---- | /O(N log N)/. Update the weights.-mapWeightsWithKey :: Ord w2-                  => (k -> w1 -> w2)-                  -> WeightedPSQ w1 k v-                  -> WeightedPSQ w2 k v-mapWeightsWithKey f (WeightedPSQ xs) = fromList $-                                       L.map (\ (w, k, v) -> (f k w, k, v)) xs---- | /O(N)/. Update the values.-mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2-mapWithKey f (WeightedPSQ xs) = WeightedPSQ $-                                L.map (\ (w, k, v) -> (w, k, f k v)) xs---- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all--- elements. Elements from the first @WeightedPSQ@ come before elements in the--- second when they have the same weight.-union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v-union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys)---- | /O(N)/. Return the prefix of values ending with the first element that--- satisfies p, or all elements if none satisfy p.-takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v-takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs)-  where-    go :: [(w, k, v)] -> [(w, k, v)]-    go []       = []-    go (y : ys) = y : if p (triple_3 y) then [] else go ys--triple_1 :: (x, y, z) -> x-triple_1 (x, _, _) = x--triple_2 :: (x, y, z) -> y-triple_2 (_, y, _) = y--triple_3 :: (x, y, z) -> z-triple_3 (_, _, z) = z
− Distribution/Solver/Types/ComponentDeps.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}---- | Fine-grained package dependencies------ Like many others, this module is meant to be "double-imported":------ > import Distribution.Solver.Types.ComponentDeps (--- >     Component--- >   , ComponentDep--- >   , ComponentDeps--- >   )--- > import qualified Distribution.Solver.Types.ComponentDeps as CD-module Distribution.Solver.Types.ComponentDeps (-    -- * Fine-grained package dependencies-    Component(..)-  , componentNameToComponent-  , ComponentDep-  , ComponentDeps -- opaque-    -- ** Constructing ComponentDeps-  , empty-  , fromList-  , singleton-  , insert-  , zip-  , filterDeps-  , fromLibraryDeps-  , fromSetupDeps-  , fromInstalled-    -- ** Deconstructing ComponentDeps-  , toList-  , flatDeps-  , nonSetupDeps-  , libraryDeps-  , setupDeps-  , select-  , components-  ) where--import Prelude ()-import Distribution.Types.UnqualComponentName-import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip)--import qualified Data.Map as Map-import Data.Foldable (fold)--import Distribution.Pretty (Pretty (..))-import qualified Distribution.Types.ComponentName as CN-import qualified Distribution.Types.LibraryName as LN-import qualified Text.PrettyPrint as PP---{--------------------------------------------------------------------------------  Types--------------------------------------------------------------------------------}---- | Component of a package.-data Component =-    ComponentLib-  | ComponentSubLib UnqualComponentName-  | ComponentFLib   UnqualComponentName-  | ComponentExe    UnqualComponentName-  | ComponentTest   UnqualComponentName-  | ComponentBench  UnqualComponentName-  | ComponentSetup-  deriving (Show, Eq, Ord, Generic)--instance Binary Component-instance Structured Component--instance Pretty Component where-    pretty ComponentLib        = PP.text "lib"-    pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n-    pretty (ComponentFLib n)   = PP.text "flib:" <<>> pretty n-    pretty (ComponentExe n)    = PP.text "exe:" <<>> pretty n-    pretty (ComponentTest n)   = PP.text "test:" <<>> pretty n-    pretty (ComponentBench n)  = PP.text "bench:" <<>> pretty n-    pretty ComponentSetup      = PP.text "setup"---- | Dependency for a single component.-type ComponentDep a = (Component, a)---- | Fine-grained dependencies for a package.------ Typically used as @ComponentDeps [Dependency]@, to represent the list of--- dependencies for each named component within a package.----newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }-  deriving (Show, Functor, Eq, Ord, Generic)--instance Semigroup a => Monoid (ComponentDeps a) where-  mempty = ComponentDeps Map.empty-  mappend = (<>)--instance Semigroup a => Semigroup (ComponentDeps a) where-  ComponentDeps d <> ComponentDeps d' =-      ComponentDeps (Map.unionWith (<>) d d')--instance Foldable ComponentDeps where-  foldMap f = foldMap f . unComponentDeps--instance Traversable ComponentDeps where-  traverse f = fmap ComponentDeps . traverse f . unComponentDeps--instance Binary a => Binary (ComponentDeps a)-instance Structured a => Structured (ComponentDeps a)--componentNameToComponent :: CN.ComponentName -> Component-componentNameToComponent (CN.CLibName  LN.LMainLibName)   = ComponentLib-componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s-componentNameToComponent (CN.CFLibName                s)  = ComponentFLib   s-componentNameToComponent (CN.CExeName                 s)  = ComponentExe    s-componentNameToComponent (CN.CTestName                s)  = ComponentTest   s-componentNameToComponent (CN.CBenchName               s)  = ComponentBench  s--{--------------------------------------------------------------------------------  Construction--------------------------------------------------------------------------------}--empty :: ComponentDeps a-empty = ComponentDeps $ Map.empty--fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a-fromList = ComponentDeps . Map.fromListWith mappend--singleton :: Component -> a -> ComponentDeps a-singleton comp = ComponentDeps . Map.singleton comp--insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a-insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps-  where-    aux Nothing   = Just a-    aux (Just a') = Just $ a `mappend` a'---- | Zip two 'ComponentDeps' together by 'Component', using 'mempty'--- as the neutral element when a 'Component' is present only in one.-zip-  :: (Monoid a, Monoid b)-  => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)-zip (ComponentDeps d1) (ComponentDeps d2) =-    ComponentDeps $-      Map.mergeWithKey-        (\_ a b -> Just (a,b))-        (fmap (\a -> (a, mempty)))-        (fmap (\b -> (mempty, b)))-        d1 d2---- | Keep only selected components (and their associated deps info).-filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a-filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps---- | ComponentDeps containing library dependencies only-fromLibraryDeps :: a -> ComponentDeps a-fromLibraryDeps = singleton ComponentLib---- | ComponentDeps containing setup dependencies only.-fromSetupDeps :: a -> ComponentDeps a-fromSetupDeps = singleton ComponentSetup---- | ComponentDeps for installed packages.------ We assume that installed packages only record their library dependencies.-fromInstalled :: a -> ComponentDeps a-fromInstalled = fromLibraryDeps--{--------------------------------------------------------------------------------  Deconstruction--------------------------------------------------------------------------------}--toList :: ComponentDeps a -> [ComponentDep a]-toList = Map.toList . unComponentDeps---- | All dependencies of a package.------ This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more--- obvious than a use of 'fold', and moreover this avoids introducing lots of--- @#ifdef@s for 7.10 just for the use of 'fold'.-flatDeps :: Monoid a => ComponentDeps a -> a-flatDeps = fold---- | All dependencies except the setup dependencies.------ Prior to the introduction of setup dependencies in version 1.24 this--- would have been _all_ dependencies.-nonSetupDeps :: Monoid a => ComponentDeps a -> a-nonSetupDeps = select (/= ComponentSetup)---- | Library dependencies proper only.  (Includes dependencies--- of internal libraries.)-libraryDeps :: Monoid a => ComponentDeps a -> a-libraryDeps = select (\c -> case c of ComponentSubLib _ -> True-                                      ComponentLib -> True-                                      _ -> False)---- | List components-components :: ComponentDeps a -> Set Component-components = Map.keysSet . unComponentDeps---- | Setup dependencies.-setupDeps :: Monoid a => ComponentDeps a -> a-setupDeps = select (== ComponentSetup)---- | Select dependencies satisfying a given predicate.-select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a-select p = foldMap snd . filter (p . fst) . toList
− Distribution/Solver/Types/ConstraintSource.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.ConstraintSource-    ( ConstraintSource(..)-    , showConstraintSource-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()---- | Source of a 'PackageConstraint'.-data ConstraintSource =--  -- | Main config file, which is ~/.cabal/config by default.-  ConstraintSourceMainConfig FilePath--  -- | Local cabal.project file-  | ConstraintSourceProjectConfig FilePath--  -- | Sandbox config file, which is ./cabal.sandbox.config by default.-  | ConstraintSourceSandboxConfig FilePath--  -- | User config file, which is ./cabal.config by default.-  | ConstraintSourceUserConfig FilePath--  -- | Flag specified on the command line.-  | ConstraintSourceCommandlineFlag--  -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@-  -- implies @package==0.1.0.0@.-  | ConstraintSourceUserTarget--  -- | Internal requirement to use installed versions of packages like ghc-prim.-  | ConstraintSourceNonUpgradeablePackage--  -- | Internal requirement to use the add-source version of a package when that-  -- version is installed and the source is modified.-  | ConstraintSourceModifiedAddSourceDep--  -- | Internal constraint used by @cabal freeze@.-  | ConstraintSourceFreeze--  -- | Constraint specified by a config file, a command line flag, or a user-  -- target, when a more specific source is not known.-  | ConstraintSourceConfigFlagOrTarget--  -- | The source of the constraint is not specified.-  | ConstraintSourceUnknown--  -- | An internal constraint due to compatibility issues with the Setup.hs-  -- command line interface requires a minimum lower bound on Cabal-  | ConstraintSetupCabalMinVersion--  -- | An internal constraint due to compatibility issues with the Setup.hs-  -- command line interface requires a maximum upper bound on Cabal-  | ConstraintSetupCabalMaxVersion-  deriving (Eq, Show, Generic)--instance Binary ConstraintSource-instance Structured ConstraintSource---- | Description of a 'ConstraintSource'.-showConstraintSource :: ConstraintSource -> String-showConstraintSource (ConstraintSourceMainConfig path) =-    "main config " ++ path-showConstraintSource (ConstraintSourceProjectConfig path) =-    "project config " ++ path-showConstraintSource (ConstraintSourceSandboxConfig path) =-    "sandbox config " ++ path-showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path-showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"-showConstraintSource ConstraintSourceUserTarget = "user target"-showConstraintSource ConstraintSourceNonUpgradeablePackage =-    "non-upgradeable package"-showConstraintSource ConstraintSourceModifiedAddSourceDep =-    "modified add-source dependency"-showConstraintSource ConstraintSourceFreeze = "cabal freeze"-showConstraintSource ConstraintSourceConfigFlagOrTarget =-    "config file, command line flag, or user target"-showConstraintSource ConstraintSourceUnknown = "unknown source"-showConstraintSource ConstraintSetupCabalMinVersion =-    "minimum version of Cabal used by Setup.hs"-showConstraintSource ConstraintSetupCabalMaxVersion =-    "maximum version of Cabal used by Setup.hs"
− Distribution/Solver/Types/DependencyResolver.hs 
@@ -1,37 +0,0 @@-module Distribution.Solver.Types.DependencyResolver-    ( DependencyResolver-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Solver.Types.LabeledPackageConstraint-import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb )-import Distribution.Solver.Types.PackagePreferences-import Distribution.Solver.Types.PackageIndex ( PackageIndex )-import Distribution.Solver.Types.Progress-import Distribution.Solver.Types.ResolverPackage-import Distribution.Solver.Types.SourcePackage--import Distribution.Simple.PackageIndex ( InstalledPackageIndex )-import Distribution.Package ( PackageName )-import Distribution.Compiler ( CompilerInfo )-import Distribution.System ( Platform )---- | A dependency resolver is a function that works out an installation plan--- given the set of installed and available packages and a set of deps to--- solve for.------ The reason for this interface is because there are dozens of approaches to--- solving the package dependency problem and we want to make it easy to swap--- in alternatives.----type DependencyResolver loc = Platform-                           -> CompilerInfo-                           -> InstalledPackageIndex-                           -> PackageIndex (SourcePackage loc)-                           -> PkgConfigDb-                           -> (PackageName -> PackagePreferences)-                           -> [LabeledPackageConstraint]-                           -> Set PackageName-                           -> Progress String String [ResolverPackage loc]
− Distribution/Solver/Types/Flag.hs 
@@ -1,8 +0,0 @@-module Distribution.Solver.Types.Flag-    ( FlagType(..)-    ) where--import Prelude (Eq, Show)--data FlagType = Manual | Automatic-  deriving (Eq, Show)
− Distribution/Solver/Types/InstSolverPackage.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.InstSolverPackage-    ( InstSolverPackage(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) )-import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )-import Distribution.Solver.Types.SolverId-import Distribution.Types.MungedPackageId-import Distribution.Types.PackageId-import Distribution.Types.MungedPackageName-import Distribution.InstalledPackageInfo (InstalledPackageInfo)---- | An 'InstSolverPackage' is a pre-existing installed package--- specified by the dependency solver.-data InstSolverPackage = InstSolverPackage {-      instSolverPkgIPI :: InstalledPackageInfo,-      instSolverPkgLibDeps :: ComponentDeps [SolverId],-      instSolverPkgExeDeps :: ComponentDeps [SolverId]-    }-  deriving (Eq, Show, Generic)--instance Binary InstSolverPackage-instance Structured InstSolverPackage--instance Package InstSolverPackage where-    packageId i =-        -- HACK! See Note [Index conversion with internal libraries]-        let MungedPackageId mpn v = mungedId i-        in PackageIdentifier (encodeCompatPackageName mpn) v--instance HasMungedPackageId InstSolverPackage where-    mungedId = mungedId . instSolverPkgIPI--instance HasUnitId InstSolverPackage where-    installedUnitId = installedUnitId . instSolverPkgIPI
− Distribution/Solver/Types/InstalledPreference.hs 
@@ -1,11 +0,0 @@-module Distribution.Solver.Types.InstalledPreference-    ( InstalledPreference(..),-    ) where--import Prelude (Show)---- | Whether we prefer an installed version of a package or simply the latest--- version.----data InstalledPreference = PreferInstalled | PreferLatest-  deriving Show
− Distribution/Solver/Types/LabeledPackageConstraint.hs 
@@ -1,14 +0,0 @@-module Distribution.Solver.Types.LabeledPackageConstraint-    ( LabeledPackageConstraint(..)-    , unlabelPackageConstraint-    ) where--import Distribution.Solver.Types.ConstraintSource-import Distribution.Solver.Types.PackageConstraint---- | 'PackageConstraint' labeled with its source.-data LabeledPackageConstraint-   = LabeledPackageConstraint PackageConstraint ConstraintSource--unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint-unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
− Distribution/Solver/Types/OptionalStanza.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Distribution.Solver.Types.OptionalStanza-    ( OptionalStanza(..)-    , showStanza-    , enableStanzas-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()-import Distribution.Types.ComponentRequestedSpec-            (ComponentRequestedSpec(..), defaultComponentRequestedSpec)--data OptionalStanza-    = TestStanzas-    | BenchStanzas-  deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable)---- | String representation of an OptionalStanza.-showStanza :: OptionalStanza -> String-showStanza TestStanzas  = "test"-showStanza BenchStanzas = "bench"---- | Convert a list of 'OptionalStanza' into the corresponding--- 'ComponentRequestedSpec' which records what components are enabled.-enableStanzas :: [OptionalStanza] -> ComponentRequestedSpec-enableStanzas = foldl' addStanza defaultComponentRequestedSpec-  where-    addStanza enabled TestStanzas  = enabled { testsRequested = True }-    addStanza enabled BenchStanzas = enabled { benchmarksRequested = True }--instance Binary OptionalStanza-instance Structured OptionalStanza
− Distribution/Solver/Types/PackageConstraint.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---- | Per-package constraints. Package constraints must be respected by the--- solver. Multiple constraints for each package can be given, though obviously--- it is possible to construct conflicting constraints (eg impossible version--- range or inconsistent flag assignment).----module Distribution.Solver.Types.PackageConstraint (-    ConstraintScope(..),-    scopeToplevel,-    scopeToPackageName,-    constraintScopeMatches,-    PackageProperty(..),-    dispPackageProperty,-    PackageConstraint(..),-    dispPackageConstraint,-    showPackageConstraint,-    packageConstraintToDependency-  ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package                        (PackageName)-import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)-import Distribution.Pretty                         (flatStyle, pretty)-import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))-import Distribution.Version                        (VersionRange, simplifyVersionRange)--import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.PackagePath--import qualified Text.PrettyPrint as Disp----- | Determines to what packages and in what contexts a--- constraint applies.-data ConstraintScope-     -- | A scope that applies when the given package is used as a build target.-     -- In other words, the scope applies iff a goal has a top-level qualifier-     -- and its namespace matches the given package name. A namespace is-     -- considered to match a package name when it is either the default-     -- namespace (for --no-independent-goals) or it is an independent namespace-     -- with the given package name (for --independent-goals).--     -- TODO: Try to generalize the ConstraintScopes once component-based-     -- solving is implemented, and remove this special case for targets.-   = ScopeTarget PackageName-     -- | The package with the specified name and qualifier.-   | ScopeQualified Qualifier PackageName-     -- | The package with the specified name when it has a-     -- setup qualifier.-   | ScopeAnySetupQualifier PackageName-     -- | The package with the specified name regardless of-     -- qualifier.-   | ScopeAnyQualifier PackageName-  deriving (Eq, Show)---- | Constructor for a common use case: the constraint applies to--- the package with the specified name when that package is a--- top-level dependency in the default namespace.-scopeToplevel :: PackageName -> ConstraintScope-scopeToplevel = ScopeQualified QualToplevel---- | Returns the package name associated with a constraint scope.-scopeToPackageName :: ConstraintScope -> PackageName-scopeToPackageName (ScopeTarget pn) = pn-scopeToPackageName (ScopeQualified _ pn) = pn-scopeToPackageName (ScopeAnySetupQualifier pn) = pn-scopeToPackageName (ScopeAnyQualifier pn) = pn--constraintScopeMatches :: ConstraintScope -> QPN -> Bool-constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') =-  let namespaceMatches DefaultNamespace = True-      namespaceMatches (Independent namespacePn) = pn == namespacePn-  in namespaceMatches ns && q == QualToplevel && pn == pn'-constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =-    q == q' && pn == pn'-constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =-  let setup (PackagePath _ (QualSetup _)) = True-      setup _                             = False-  in setup pp && pn == pn'-constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'---- | Pretty-prints a constraint scope.-dispConstraintScope :: ConstraintScope -> Disp.Doc-dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn-dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn-dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn-dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn---- | A package property is a logical predicate on packages.-data PackageProperty-   = PackagePropertyVersion   VersionRange-   | PackagePropertyInstalled-   | PackagePropertySource-   | PackagePropertyFlags     FlagAssignment-   | PackagePropertyStanzas   [OptionalStanza]-  deriving (Eq, Show, Generic)--instance Binary PackageProperty-instance Structured PackageProperty---- | Pretty-prints a package property.-dispPackageProperty :: PackageProperty -> Disp.Doc-dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange-dispPackageProperty PackagePropertyInstalled          = Disp.text "installed"-dispPackageProperty PackagePropertySource             = Disp.text "source"-dispPackageProperty (PackagePropertyFlags flags)      = dispFlagAssignment flags-dispPackageProperty (PackagePropertyStanzas stanzas)  =-  Disp.hsep $ map (Disp.text . showStanza) stanzas---- | A package constraint consists of a scope plus a property--- that must hold for all packages within that scope.-data PackageConstraint = PackageConstraint ConstraintScope PackageProperty-  deriving (Eq, Show)---- | Pretty-prints a package constraint.-dispPackageConstraint :: PackageConstraint -> Disp.Doc-dispPackageConstraint (PackageConstraint scope prop) =-  dispConstraintScope scope <+> dispPackageProperty prop---- | Alternative textual representation of a package constraint--- for debugging purposes (slightly more verbose than that--- produced by 'dispPackageConstraint').----showPackageConstraint :: PackageConstraint -> String-showPackageConstraint pc@(PackageConstraint scope prop) =-  Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2-  where-    pc2 = case prop of-      PackagePropertyVersion vr ->-        PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr)-      _ -> pc-    postprocess = case prop of-      PackagePropertyFlags _ -> (Disp.text "flags" <+>)-      PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>)-      _ -> id---- | Lossily convert a 'PackageConstraint' to a 'Dependency'.-packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint-packageConstraintToDependency (PackageConstraint scope prop) = toDep prop-  where-    toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr-    toDep (PackagePropertyInstalled)  = Nothing-    toDep (PackagePropertySource)     = Nothing-    toDep (PackagePropertyFlags _)    = Nothing-    toDep (PackagePropertyStanzas _)  = Nothing
− Distribution/Solver/Types/PackageFixedDeps.hs 
@@ -1,23 +0,0 @@-module Distribution.Solver.Types.PackageFixedDeps-    ( PackageFixedDeps(..)-    ) where--import           Distribution.InstalledPackageInfo ( InstalledPackageInfo )-import           Distribution.Package-                   ( Package(..), UnitId, installedDepends)-import           Distribution.Solver.Types.ComponentDeps ( ComponentDeps )-import qualified Distribution.Solver.Types.ComponentDeps as CD---- | Subclass of packages that have specific versioned dependencies.------ So for example a not-yet-configured package has dependencies on version--- ranges, not specific versions. A configured or an already installed package--- depends on exact versions. Some operations or data structures (like---  dependency graphs) only make sense on this subclass of package types.----class Package pkg => PackageFixedDeps pkg where-  depends :: pkg -> ComponentDeps [UnitId]--instance PackageFixedDeps InstalledPackageInfo where-  depends pkg = CD.fromInstalled (installedDepends pkg)-
− Distribution/Solver/Types/PackageIndex.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Solver.Types.PackageIndex--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ An index of packages.----module Distribution.Solver.Types.PackageIndex (-  -- * Package index data type-  PackageIndex,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,-  override,-  insert,-  deletePackageName,-  deletePackageId,-  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  elemByPackageId,-  elemByPackageName,-  lookupPackageName,-  lookupPackageId,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,-  searchWithPredicate,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,-  ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (lookup)--import Control.Exception (assert)-import qualified Data.Map as Map-import Data.List (isInfixOf)-import qualified Data.List.NonEmpty as NE--import Distribution.Package-         ( PackageName, unPackageName, PackageIdentifier(..)-         , Package(..), packageName, packageVersion )-import Distribution.Version-         ( VersionRange, withinRange )-import Distribution.Simple.Utils-         ( lowercase )--import qualified Prelude (foldr1)---- | The collection of information about packages from one or more 'PackageDB's.------ 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-  -- name case-sensitively. It includes all versions.-  ---  -- This allows us to find all versions satisfying a dependency.-  -- Most queries are a map lookup followed by a linear scan of the bucket.-  ---  (Map PackageName [pkg])--  deriving (Eq, Show, Read, Functor, Generic)---FIXME: the Functor instance here relies on no package id changes--instance Package pkg => Semigroup (PackageIndex pkg) where-  (<>) = merge--instance Package pkg => Monoid (PackageIndex pkg) where-  mempty  = PackageIndex Map.empty-  mappend = (<>)-  --save one mappend with empty in the common case:-  mconcat [] = mempty-  mconcat xs = Prelude.foldr1 mappend xs--instance Binary pkg => Binary (PackageIndex pkg)--invariant :: Package pkg => PackageIndex pkg -> Bool-invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)-  where-    goodBucket _    [] = False-    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0-      where-        check pkgid []          = packageName pkgid == name-        check pkgid (pkg':pkgs) = packageName pkgid == name-                               && pkgid < pkgid'-                               && check pkgid' pkgs-          where pkgid' = packageId pkg'------- * Internal helpers-----mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg-mkPackageIndex index = assert (invariant (PackageIndex index))-                                         (PackageIndex index)--internalError :: String -> a-internalError name = error ("PackageIndex." ++ name ++ ": internal error")---- | Lookup a name in the index to get all packages that match that name--- case-sensitively.----lookup :: PackageIndex pkg -> PackageName -> [pkg]-lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m------- * Construction------- | Build an index out of a bunch of packages.------ If there are duplicates, later ones mask earlier ones.----fromList :: Package pkg => [pkg] -> PackageIndex pkg-fromList pkgs = mkPackageIndex-              . Map.map fixBucket-              . Map.fromListWith (++)-              $ [ (packageName pkg, [pkg])-                | pkg <- pkgs ]-  where-    fixBucket = -- out of groups of duplicates, later ones mask earlier ones-                -- but Map.fromListWith (++) constructs groups in reverse order-                map NE.head-                -- Eq instance for PackageIdentifier is wrong, so use Ord:-              . NE.groupBy (\a b -> EQ == comparing packageId a b)-                -- relies on sortBy being a stable sort so we-                -- can pick consistently among duplicates-              . sortBy (comparing packageId)------- * Updates------- | Merge two indexes.------ Packages from the second mask packages of the same exact name--- (case-sensitively) from the first.----merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg-merge i1@(PackageIndex m1) i2@(PackageIndex m2) =-  assert (invariant i1 && invariant i2) $-    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)----- | Elements in the second list mask those in the first.-mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]-mergeBuckets []     ys     = ys-mergeBuckets xs     []     = xs-mergeBuckets xs@(x:xs') ys@(y:ys') =-      case packageId x `compare` packageId y of-        GT -> y : mergeBuckets xs  ys'-        EQ -> y : mergeBuckets xs' ys'-        LT -> x : mergeBuckets xs' ys---- | Override-merge oftwo indexes.------ Packages from the second mask packages of the same exact name--- (case-sensitively) from the first.----override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg-override i1@(PackageIndex m1) i2@(PackageIndex m2) =-  assert (invariant i1 && invariant i2) $-    mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2)---- | Inserts a single package into the index.------ This is equivalent to (but slightly quicker than) using 'mappend' or--- 'merge' with a singleton index.----insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg-insert pkg (PackageIndex index) = mkPackageIndex $-  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index-  where-    pkgid = packageId pkg-    insertNoDup []                = [pkg]-    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of-      LT -> pkg  : pkgs-      EQ -> pkg  : pkgs'-      GT -> pkg' : insertNoDup pkgs'---- | Internal delete helper.----delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg-       -> PackageIndex pkg-delete name p (PackageIndex index) = mkPackageIndex $-  Map.update filterBucket name index-  where-    filterBucket = deleteEmptyBucket-                 . filter (not . p)-    deleteEmptyBucket []        = Nothing-    deleteEmptyBucket remaining = Just remaining---- | Removes a single package from the index.----deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg-                -> PackageIndex pkg-deletePackageId pkgid =-  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)---- | Removes all packages with this (case-sensitive) name from the index.----deletePackageName :: Package pkg => PackageName -> PackageIndex pkg-                  -> PackageIndex pkg-deletePackageName name =-  delete name (\pkg -> packageName pkg == name)---- | Removes all packages satisfying this dependency from the index.-deleteDependency :: Package pkg-                 => PackageName -> VersionRange -> PackageIndex pkg-                 -> PackageIndex pkg-deleteDependency name verstionRange =-  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)------- * Bulk queries------- | Get all the packages from the index.----allPackages :: PackageIndex pkg -> [pkg]-allPackages (PackageIndex m) = concat (Map.elems m)---- | Get all the packages from the index.------ They are grouped by package name, case-sensitively.----allPackagesByName :: PackageIndex pkg -> [[pkg]]-allPackagesByName (PackageIndex m) = Map.elems m------- * Lookups-----elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool-elemByPackageId index = isJust . lookupPackageId index--elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool-elemByPackageName index = not . null . lookupPackageName index----- | Does a lookup by package id (name & version).------ Since multiple package DBs mask each other case-sensitively by package name,--- then we get back at most one package.----lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier-                -> Maybe pkg-lookupPackageId index pkgid =-  case [ pkg | pkg <- lookup index (packageName pkgid)-             , packageId pkg == pkgid ] of-    []    -> Nothing-    [pkg] -> Just pkg-    _     -> internalError "lookupPackageIdentifier"---- | Does a case-sensitive search by package name.----lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]-lookupPackageName index name =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name ]---- | Does a case-sensitive search by package name and a range of versions.------ We get back any number of versions of the specified package name, all--- satisfying the version range constraint.----lookupDependency :: Package pkg-                 => PackageIndex pkg-                 -> PackageName -> VersionRange-                 -> [pkg]-lookupDependency index name versionRange =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name-        , packageVersion pkg `withinRange` versionRange ]------- * Case insensitive name lookups------- | Does a case-insensitive search by package 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-insensitively but one matches exactly then it is also--- unambiguous.------ 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.----searchByName :: PackageIndex pkg-             -> String -> [(PackageName, [pkg])]-searchByName (PackageIndex m) name =-    [ pkgs-    | pkgs@(pname,_) <- Map.toList m-    , lowercase (unPackageName pname) == lname ]-  where-    lname = lowercase name--data SearchResult a = None | Unambiguous a | Ambiguous [a]---- | Does a case-insensitive substring search by package name.------ That is, all packages that contain the given string in their name.----searchByNameSubstring :: PackageIndex pkg-                      -> String -> [(PackageName, [pkg])]-searchByNameSubstring index searchterm =-    searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)-  where lsearchterm = lowercase searchterm--searchWithPredicate :: PackageIndex pkg-                    -> (String -> Bool) -> [(PackageName, [pkg])]-searchWithPredicate (PackageIndex m) predicate =-    [ pkgs-    | pkgs@(pname, _) <- Map.toList m-    , predicate (unPackageName pname)-    ]
− Distribution/Solver/Types/PackagePath.hs 
@@ -1,102 +0,0 @@-module Distribution.Solver.Types.PackagePath-    ( PackagePath(..)-    , Namespace(..)-    , Qualifier(..)-    , dispQualifier-    , Qualified(..)-    , QPN-    , dispQPN-    , showQPN-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()-import Distribution.Package (PackageName)-import Distribution.Pretty (pretty, flatStyle)-import qualified Text.PrettyPrint as Disp---- | A package path consists of a namespace and a package path inside that--- namespace.-data PackagePath = PackagePath Namespace Qualifier-  deriving (Eq, Ord, Show)---- | Top-level namespace------ Package choices in different namespaces are considered completely independent--- by the solver.-data Namespace =-    -- | The default namespace-    DefaultNamespace--    -- | A namespace for a specific build target-  | Independent PackageName-  deriving (Eq, Ord, Show)---- | Pretty-prints a namespace. The result is either empty or--- ends in a period, so it can be prepended onto a qualifier.-dispNamespace :: Namespace -> Disp.Doc-dispNamespace DefaultNamespace = Disp.empty-dispNamespace (Independent i) = pretty i <<>> Disp.text "."---- | Qualifier of a package within a namespace (see 'PackagePath')-data Qualifier =-    -- | Top-level dependency in this namespace-    QualToplevel--    -- | Any dependency on base is considered independent-    ---    -- This makes it possible to have base shims.-  | QualBase PackageName--    -- | Setup dependency-    ---    -- By rights setup dependencies ought to be nestable; after all, the setup-    -- dependencies of a package might themselves have setup dependencies, which-    -- are independent from everything else. However, this very quickly leads to-    -- infinite search trees in the solver. Therefore we limit ourselves to-    -- a single qualifier (within a given namespace).-  | QualSetup PackageName--    -- | If we depend on an executable from a package (via-    -- @build-tools@), we should solve for the dependencies of that-    -- package separately (since we're not going to actually try to-    -- link it.)  We qualify for EACH package separately; e.g.,-    -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on-    -- @pn2@ from package @pn1@.  (If we tracked only @pn1@, that-    -- would require a consistent dependency resolution for all-    -- of the depended upon executables from a package; if we-    -- tracked only @pn2@, that would require us to pick only one-    -- version of an executable over the entire install plan.)-  | QualExe PackageName PackageName-  deriving (Eq, Ord, Show)---- | Pretty-prints a qualifier. The result is either empty or--- ends in a period, so it can be prepended onto a package name.------ NOTE: the base qualifier is for a dependency _on_ base; the qualifier is--- there to make sure different dependencies on base are all independent.--- So we want to print something like @"A.base"@, where the @"A."@ part--- is the qualifier and @"base"@ is the actual dependency (which, for the--- 'Base' qualifier, will always be @base@).-dispQualifier :: Qualifier -> Disp.Doc-dispQualifier QualToplevel = Disp.empty-dispQualifier (QualSetup pn)  = pretty pn <<>> Disp.text ":setup."-dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>-                                 pretty pn2 <<>> Disp.text ":exe."-dispQualifier (QualBase pn)  = pretty pn <<>> Disp.text "."---- | A qualified entity. Pairs a package path with the entity.-data Qualified a = Q PackagePath a-  deriving (Eq, Ord, Show)---- | Qualified package name.-type QPN = Qualified PackageName---- | Pretty-prints a qualified package name.-dispQPN :: QPN -> Disp.Doc-dispQPN (Q (PackagePath ns qual) pn) =-  dispNamespace ns <<>> dispQualifier qual <<>> pretty pn---- | String representation of a qualified package name.-showQPN :: QPN -> String-showQPN = Disp.renderStyle flatStyle . dispQPN
− Distribution/Solver/Types/PackagePreferences.hs 
@@ -1,22 +0,0 @@-module Distribution.Solver.Types.PackagePreferences-    ( PackagePreferences(..)-    ) where--import Distribution.Solver.Types.InstalledPreference-import Distribution.Solver.Types.OptionalStanza-import Distribution.Version (VersionRange)---- | Per-package preferences on the version. It is a soft constraint that the--- 'DependencyResolver' should try to respect where possible. It consists of--- an 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also has (possibly multiple)--- 'PackageVersionPreference's which are suggested constraints on the version--- number. The resolver should try to use package versions that satisfy--- the maximum number of the suggested version constraints.------ It is not specified if preferences on some packages are more important than--- others.----data PackagePreferences = PackagePreferences [VersionRange]-                                             InstalledPreference-                                             [OptionalStanza]
− Distribution/Solver/Types/PkgConfigDb.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Solver.Types.PkgConfigDb--- Copyright   :  (c) Iñaki García Etxebarria 2016--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Read the list of packages available to pkg-config.-------------------------------------------------------------------------------module Distribution.Solver.Types.PkgConfigDb-    ( PkgConfigDb-    , readPkgConfigDb-    , pkgConfigDbFromList-    , pkgConfigPkgIsPresent-    , pkgConfigDbPkgVersion-    , getPkgConfigDbDirs-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import           Control.Exception (handle)-import qualified Data.Map          as M-import           System.FilePath   (splitSearchPath)--import Distribution.Compat.Environment          (lookupEnv)-import Distribution.Package                     (PkgconfigName, mkPkgconfigName)-import Distribution.Parsec-import Distribution.Simple.Program-       (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram)-import Distribution.Simple.Utils                (info)-import Distribution.Types.PkgconfigVersion-import Distribution.Types.PkgconfigVersionRange-import Distribution.Verbosity                   (Verbosity)---- | The list of packages installed in the system visible to--- @pkg-config@. This is an opaque datatype, to be constructed with--- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`.-data PkgConfigDb =  PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion))-                 -- ^ If an entry is `Nothing`, this means that the-                 -- package seems to be present, but we don't know the-                 -- exact version (because parsing of the version-                 -- number failed).-                 | NoPkgConfigDb-                 -- ^ For when we could not run pkg-config successfully.-     deriving (Show, Generic, Typeable)--instance Binary PkgConfigDb-instance Structured PkgConfigDb---- | Query pkg-config for the list of installed packages, together--- with their versions. Return a `PkgConfigDb` encapsulating this--- information.-readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb-readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do-    mpkgConfig <- needProgram verbosity pkgConfigProgram progdb-    case mpkgConfig of-      Nothing             -> noPkgConfig "Cannot find pkg-config program"-      Just (pkgConfig, _) -> do-        pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]-        -- The output of @pkg-config --list-all@ also includes a description-        -- for each package, which we do not need.-        let pkgNames = map (takeWhile (not . isSpace)) pkgList-        pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig-                                   ("--modversion" : pkgNames)-        (return . pkgConfigDbFromList . zip pkgNames) pkgVersions-  where-    -- For when pkg-config invocation fails (possibly because of a-    -- too long command line).-    noPkgConfig extra = do-        info verbosity ("Failed to query pkg-config, Cabal will continue"-                        ++ " without solving for pkg-config constraints: "-                        ++ extra)-        return NoPkgConfigDb--    ioErrorHandler :: IOException -> IO PkgConfigDb-    ioErrorHandler e = noPkgConfig (show e)---- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs.-pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb-pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs-    where-      convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion)-      convert (n,vs) = (mkPkgconfigName n, simpleParsec vs)---- | Check whether a given package range is satisfiable in the given--- @pkg-config@ database.-pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool-pkgConfigPkgIsPresent (PkgConfigDb db) pn vr =-    case M.lookup pn db of-      Nothing       -> False    -- Package not present in the DB.-      Just Nothing  -> True     -- Package present, but version unknown.-      Just (Just v) -> withinPkgconfigVersionRange v vr--- If we could not read the pkg-config database successfully we allow--- the check to succeed. The plan found by the solver may fail to be--- executed later on, but we have no grounds for rejecting the plan at--- this stage.-pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True----- | Query the version of a package in the @pkg-config@ database.--- @Nothing@ indicates the package is not in the database, while--- @Just Nothing@ indicates that the package is in the database,--- but its version is not known.-pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion)-pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db--- NB: Since the solver allows solving to succeed if there is--- NoPkgConfigDb, we should report that we *guess* that there--- is a matching pkg-config configuration, but that we just--- don't know about it.-pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing----- | Query pkg-config for the locations of pkg-config's package files. Use this--- to monitor for changes in the pkg-config DB.----getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath]-getPkgConfigDbDirs verbosity progdb =-    (++) <$> getEnvPath <*> getDefPath- where-    -- According to @man pkg-config@:-    ---    -- PKG_CONFIG_PATH-    -- A  colon-separated  (on Windows, semicolon-separated) list of directories-    -- to search for .pc files.  The default directory will always be searched-    -- after searching the path-    ---    getEnvPath = maybe [] parseSearchPath-             <$> lookupEnv "PKG_CONFIG_PATH"--    -- Again according to @man pkg-config@:-    ---    -- pkg-config can be used to query itself for the default search path,-    -- version number and other information, for instance using:-    ---    -- > pkg-config --variable pc_path pkg-config-    ---    getDefPath = handle ioErrorHandler $ do-      mpkgConfig <- needProgram verbosity pkgConfigProgram progdb-      case mpkgConfig of-        Nothing -> return []-        Just (pkgConfig, _) -> parseSearchPath <$>-          getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"]--    parseSearchPath str =-      case lines str of-        [p] | not (null p) -> splitSearchPath p-        _                  -> []--    ioErrorHandler :: IOException -> IO [FilePath]-    ioErrorHandler _e = return []
− Distribution/Solver/Types/Progress.hs 
@@ -1,49 +0,0 @@-module Distribution.Solver.Types.Progress-    ( Progress(..)-    , foldProgress-    ) where--import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (fail)---- | A type to represent the unfolding of an expensive long running--- calculation that may fail. We may get intermediate steps before the final--- 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-                             | Done done---- This Functor instance works around a bug in GHC 7.6.3.--- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637.--- The derived functor instance caused a space leak in the solver.-instance Functor (Progress step fail) where-  fmap f (Step s p) = Step s (fmap f p)-  fmap _ (Fail x)   = Fail x-  fmap f (Done r)   = Done (f r)---- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two--- base cases, one for a final result and one for failure.------ Eg to convert into a simple 'Either' result use:------ > foldProgress (flip const) Left Right----foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)-             -> Progress step fail done -> a-foldProgress step fail done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = fail f-        fold (Done r)   = done r--instance Monad (Progress step fail) where-  return   = pure-  p >>= f  = foldProgress Step Fail f p--instance Applicative (Progress step fail) where-  pure a  = Done a-  p <*> x = foldProgress Step Fail (flip fmap x) p--instance Monoid fail => Alternative (Progress step fail) where-  empty   = Fail mempty-  p <|> q = foldProgress Step (const q) Done p
− Distribution/Solver/Types/ResolverPackage.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.ResolverPackage-    ( ResolverPackage(..)-    , resolverPackageLibDeps-    , resolverPackageExeDeps-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Solver.Types.InstSolverPackage-import Distribution.Solver.Types.SolverId-import Distribution.Solver.Types.SolverPackage-import qualified Distribution.Solver.Types.ComponentDeps as CD--import Distribution.Compat.Graph (IsNode(..))-import Distribution.Package (Package(..), HasUnitId(..))-import Distribution.Simple.Utils (ordNub)---- | The dependency resolver picks either pre-existing installed packages--- or it picks source packages along with package configuration.------ This is like the 'InstallPlan.PlanPackage' but with fewer cases.----data ResolverPackage loc = PreExisting InstSolverPackage-                         | Configured  (SolverPackage loc)-  deriving (Eq, Show, Generic)--instance Binary loc => Binary (ResolverPackage loc)-instance Structured loc => Structured (ResolverPackage loc)--instance Package (ResolverPackage loc) where-  packageId (PreExisting ipkg)     = packageId ipkg-  packageId (Configured  spkg)     = packageId spkg--resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]-resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg-resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg--resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]-resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg-resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg--instance IsNode (ResolverPackage loc) where-  type Key (ResolverPackage loc) = SolverId-  nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg)-  nodeKey (Configured spkg) = PlannedId (packageId spkg)-  -- Use dependencies for ALL components-  nodeNeighbors pkg =-    ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++-             CD.flatDeps (resolverPackageExeDeps pkg)
− Distribution/Solver/Types/Settings.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Distribution.Solver.Types.Settings-    ( ReorderGoals(..)-    , IndependentGoals(..)-    , MinimizeConflictSet(..)-    , AvoidReinstalls(..)-    , ShadowPkgs(..)-    , StrongFlags(..)-    , AllowBootLibInstalls(..)-    , OnlyConstrained(..)-    , EnableBackjumping(..)-    , CountConflicts(..)-    , FineGrainedConflicts(..)-    , SolveExecutables(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Simple.Setup ( BooleanFlag(..) )-import Distribution.Pretty ( Pretty(pretty) )-import Distribution.Parsec ( Parsec(parsec) )--import qualified Distribution.Compat.CharParsing as P-import qualified Text.PrettyPrint as PP--newtype ReorderGoals = ReorderGoals Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype CountConflicts = CountConflicts Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype FineGrainedConflicts = FineGrainedConflicts Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype MinimizeConflictSet = MinimizeConflictSet Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype IndependentGoals = IndependentGoals Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype AvoidReinstalls = AvoidReinstalls Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype ShadowPkgs = ShadowPkgs Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype StrongFlags = StrongFlags Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype AllowBootLibInstalls = AllowBootLibInstalls Bool-  deriving (BooleanFlag, Eq, Generic, Show)---- | Should we consider all packages we know about, or only those that--- have constraints explicitly placed on them or which are goals?-data OnlyConstrained-  = OnlyConstrainedNone-  | OnlyConstrainedAll-  deriving (Eq, Generic, Show)--newtype EnableBackjumping = EnableBackjumping Bool-  deriving (BooleanFlag, Eq, Generic, Show)--newtype SolveExecutables = SolveExecutables Bool-  deriving (BooleanFlag, Eq, Generic, Show)--instance Binary ReorderGoals-instance Binary CountConflicts-instance Binary FineGrainedConflicts-instance Binary IndependentGoals-instance Binary MinimizeConflictSet-instance Binary AvoidReinstalls-instance Binary ShadowPkgs-instance Binary StrongFlags-instance Binary AllowBootLibInstalls-instance Binary OnlyConstrained-instance Binary SolveExecutables--instance Structured ReorderGoals-instance Structured CountConflicts-instance Structured FineGrainedConflicts-instance Structured IndependentGoals-instance Structured MinimizeConflictSet-instance Structured AvoidReinstalls-instance Structured ShadowPkgs-instance Structured StrongFlags-instance Structured AllowBootLibInstalls-instance Structured OnlyConstrained-instance Structured SolveExecutables--instance Pretty OnlyConstrained where-  pretty OnlyConstrainedAll  = PP.text "all"-  pretty OnlyConstrainedNone = PP.text "none"--instance Parsec OnlyConstrained where-  parsec = P.choice-    [ P.string "all"  >> return OnlyConstrainedAll-    , P.string "none" >> return OnlyConstrainedNone-    ]-
− Distribution/Solver/Types/SolverId.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.SolverId-    ( SolverId(..)-    )--where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package (PackageId, Package(..), UnitId)---- | The solver can produce references to existing packages or--- packages we plan to install.  Unlike 'ConfiguredId' we don't--- yet know the 'UnitId' for planned packages, because it's--- not the solver's job to compute them.----data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId }-              | PlannedId     { solverSrcId :: PackageId }-  deriving (Eq, Ord, Generic)--instance Binary SolverId-instance Structured SolverId--instance Show SolverId where-    show = show . solverSrcId--instance Package SolverId where-  packageId = solverSrcId
− Distribution/Solver/Types/SolverPackage.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module Distribution.Solver.Types.SolverPackage-    ( SolverPackage(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package ( Package(..) )-import Distribution.PackageDescription ( FlagAssignment )-import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )-import Distribution.Solver.Types.OptionalStanza-import Distribution.Solver.Types.SolverId-import Distribution.Solver.Types.SourcePackage---- | A 'SolverPackage' is a package specified by the dependency solver.--- It will get elaborated into a 'ConfiguredPackage' or even an--- 'ElaboratedConfiguredPackage'.------ NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc',--- but for symmetry we have the parameter.  (Maybe it can be removed.)----data SolverPackage loc = SolverPackage {-        solverPkgSource  :: SourcePackage loc,-        solverPkgFlags   :: FlagAssignment,-        solverPkgStanzas :: [OptionalStanza],-        solverPkgLibDeps :: ComponentDeps [SolverId],-        solverPkgExeDeps :: ComponentDeps [SolverId]-    }-  deriving (Eq, Show, Generic)--instance Binary loc => Binary (SolverPackage loc)-instance Structured loc => Structured (SolverPackage loc)--instance Package (SolverPackage loc) where-  packageId = packageId . solverPkgSource
− Distribution/Solver/Types/SourcePackage.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-module Distribution.Solver.Types.SourcePackage-    ( PackageDescriptionOverride-    , SourcePackage(..)-    ) where--import Distribution.Solver.Compat.Prelude-import Prelude ()--import Distribution.Package-         ( PackageId, Package(..) )-import Distribution.PackageDescription-         ( GenericPackageDescription(..) )--import Data.ByteString.Lazy (ByteString)---- | A package description along with the location of the package sources.----data SourcePackage loc = SourcePackage-  { srcpkgPackageId     :: PackageId-  , srcpkgDescription   :: GenericPackageDescription-    -- ^ Note, this field is lazy, e.g. when reading in hackage index-    --   we parse only what we need, not whole index.-  , srcpkgSource        :: loc-  , srcpkgDescrOverride :: PackageDescriptionOverride-  }-  deriving (Eq, Show, Generic, Typeable)--instance Binary loc => Binary (SourcePackage loc)-instance Structured loc => Structured (SourcePackage loc)--instance Package (SourcePackage a) where packageId = srcpkgPackageId---- | We sometimes need to override the .cabal file in the tarball with--- the newer one from the package index.-type PackageDescriptionOverride = Maybe ByteString
− Distribution/Solver/Types/Variable.hs 
@@ -1,15 +0,0 @@-module Distribution.Solver.Types.Variable where--import Prelude (Eq, Show)--import Distribution.Solver.Types.OptionalStanza--import Distribution.PackageDescription (FlagName)---- | Variables used by the dependency solver. This type is similar to the--- internal 'Var' type.-data Variable qpn =-    PackageVar qpn-  | FlagVar qpn FlagName-  | StanzaVar qpn OptionalStanza-  deriving (Eq, Show)
README.md view
@@ -11,145 +11,3 @@  [Cabal web site]: http://www.haskell.org/cabal/ [Cabal]: ../Cabal/README.md--Installing the `cabal` command-line tool-========================================--The `cabal-install` package requires a number of other packages, most of-which come with a standard GHC installation. It requires the [network]-package, which is sometimes packaged separately by Linux distributions;-for example, on Debian or Ubuntu, it is located in the-"libghc6-network-dev" package.--`cabal` requires a few other Haskell packages that are not always-installed. The exact list is specified in the [.cabal] file or in the-[bootstrap.sh] file. All these packages are available from [Hackage].--Note that on some Unix systems you may need to install an additional-zlib development package using your system package manager; for example,-on Debian or Ubuntu, it is located in the "zlib1g-dev" package; on-Fedora, it is located in the "zlib-devel" package. It is required-because the Haskell zlib package uses the system zlib C library and-header files.--The `cabal-install` package is now part of the [Haskell Platform], so you-do not usually need to install it separately. However, if you are-starting from a minimal GHC installation, you need to install-`cabal-install` manually. Since it is an ordinary Cabal package,-`cabal-install` can be built the standard way; to facilitate this, the-process has been partially automated. It is described below.--[.cabal]: cabal-install.cabal-[network]: http://hackage.haskell.org/package/network-[Haskell Platform]: http://www.haskell.org/platform/--Quick start on Unix-like systems-----------------------------------As a convenience for users on Unix-like systems, there is a-[bootstrap.sh] script that will download and install each of-`cabal-install`'s dependencies in turn.--    $ ./bootstrap.sh--It will download and install the dependencies. The script will install the-library packages (vanilla, profiling and shared) into `$HOME/.cabal/` and the-`cabal` program into `$HOME/.cabal/bin/`. If you don't want to install profiling-and shared versions of the libraries, use--    $ EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh--You then have the choice either to place `$HOME/.cabal/bin` on your-`$PATH` or move the `cabal` program to somewhere on your `$PATH`. Next,-you can get the latest list of packages by running:--    $ cabal update--This will also create a default configuration file, if it does not-already exist, at `$HOME/.cabal/config`.--By default, `cabal` will install programs to `$HOME/.cabal/bin`. If you-do not want to add this directory to your `$PATH`, you can change-the setting in the config file; for example, you could use the-following:--    installdir: $HOME/bin---Quick start on Windows systems---------------------------------For Windows users, a precompiled program ([cabal.exe]) is provided.-Download and put it somewhere on your `%PATH%` (for example,-`C:\Program Files\Haskell\bin`.)--Next, you can get the latest list of packages by running:--    $ cabal update--This will also create a default configuration file (if it does not-already exist) at-`C:\Documents and Settings\%USERNAME%\Application Data\cabal\config`.--[cabal.exe]: http://www.haskell.org/cabal/release/cabal-install-latest/--Using `cabal`-=============--There are two sets of commands: commands for working with a local-project build tree and those for working with packages distributed-from [Hackage].--For the list of the full set of commands and flags for each command,-run:--    $ cabal help---Commands for developers for local build trees------------------------------------------------The commands for local project build trees are almost the same as the-`runghc Setup` command-line interface you may already be familiar with.-In particular, it has the following commands:--  * `cabal configure`-  * `cabal build`-  * `cabal haddock`-  * `cabal clean`-  * `cabal sdist`--The `install` command is somewhat different; it is an all-in-one-operation. If you run `cabal install` in your build tree, it will-configure, build, and install. It takes all the flags that `configure`-takes such as `--global` and `--prefix`.--In addition, `cabal` will download and install any dependencies that are-not already installed. It can also rebuild packages to ensure a-consistent set of dependencies.---Commands for released Hackage packages-----------------------------------------    $ cabal update--This command gets the latest list of packages from the [Hackage] server.-On occasion, this command must be run manually--for instance, if you-want to install a newly released package.--    $ cabal install xmonad--This command installs one or more named packages, and all their-dependencies, from Hackage. By default, it installs the latest available-version; however, you may specify exact versions or version ranges. For-example, `cabal install alex-2.2` or `cabal install parsec < 3`.--    $ cabal list xml--This does a search of the installed and available packages. It does a-case-insensitive substring match on the package name.---[Hackage]: http://hackage.haskell.org-[bootstrap.sh]: bootstrap.sh
+ cabal-install-solver/src-assertion/Distribution/Client/Utils/Assertion.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}+module Distribution.Client.Utils.Assertion (expensiveAssert) where+++#ifdef DEBUG_EXPENSIVE_ASSERTIONS+import Prelude (Bool)+import Control.Exception (assert)+import Distribution.Compat.Stack+#else+import Prelude (Bool, id)+#endif++-- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This+-- function can be used for expensive assertions that should only be turned on+-- during testing or debugging.+#ifdef DEBUG_EXPENSIVE_ASSERTIONS+expensiveAssert :: WithCallStack (Bool -> a -> a)+expensiveAssert = assert+#else+expensiveAssert :: Bool -> a -> a+expensiveAssert _ = id+#endif
+ cabal-install-solver/src/Distribution/Solver/Compat/Prelude.hs view
@@ -0,0 +1,19 @@+-- to suppress WARNING in "Distribution.Compat.Prelude.Internal"+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- | This module does two things:+--+-- * Acts as a compatibility layer, like @base-compat@.+--+-- * Provides commonly used imports.+--+-- This module is a superset of "Distribution.Compat.Prelude" (which+-- this module re-exports)+--+module Distribution.Solver.Compat.Prelude+  ( module Distribution.Compat.Prelude.Internal+  , Prelude.IO+  ) where++import Prelude (IO)+import Distribution.Compat.Prelude.Internal hiding (IO)
+ cabal-install-solver/src/Distribution/Solver/Modular.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Distribution.Solver.Modular+         ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where++-- Here, we try to map between the external cabal-install solver+-- interface and the internal interface that the solver actually+-- expects. There are a number of type conversions to perform: we+-- have to convert the package indices to the uniform index used+-- by the solver; we also have to convert the initial constraints;+-- and finally, we have to convert back the resulting install+-- plan.++import Prelude ()+import Distribution.Solver.Compat.Prelude++import qualified Data.Map as M+import Data.Set (isSubsetOf)+import Distribution.Compat.Graph+         ( IsNode(..) )+import Distribution.Compiler+         ( CompilerInfo )+import Distribution.Solver.Modular.Assignment+         ( Assignment, toCPs )+import Distribution.Solver.Modular.ConfiguredConversion+         ( convCP )+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.IndexConversion+         ( convPIs )+import Distribution.Solver.Modular.Log+         ( SolverFailure(..), displayLogMessages )+import Distribution.Solver.Modular.Package+         ( PN )+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Modular.Solver+         ( SolverConfig(..), PruneAfterFirstSuccess(..), solve )+import Distribution.Solver.Types.DependencyResolver+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.PkgConfigDb+         ( PkgConfigDb )+import Distribution.Solver.Types.Progress+import Distribution.Solver.Types.Variable+import Distribution.System+         ( Platform(..) )+import Distribution.Simple.Setup+         ( BooleanFlag(..) )+import Distribution.Simple.Utils+         ( ordNubBy )+import Distribution.Verbosity+++-- | Ties the two worlds together: classic cabal-install vs. the modular+-- solver. Performs the necessary translations before and after.+modularResolver :: SolverConfig -> DependencyResolver loc+modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =+  fmap (uncurry postprocess) $ -- convert install plan+  solve' sc cinfo idx pkgConfigDB pprefs gcs pns+    where+      -- Indices have to be converted into solver-specific uniform index.+      idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx+      -- Constraints have to be converted into a finite map indexed by PN.+      gcs    = M.fromListWith (++) (map pair pcs)+        where+          pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])++      -- Results have to be converted into an install plan. 'convCP' removes+      -- package qualifiers, which means that linked packages become duplicates+      -- and can be removed.+      postprocess a rdm = ordNubBy nodeKey $+                          map (convCP iidx sidx) (toCPs a rdm)++      -- Helper function to extract the PN from a constraint.+      pcName :: PackageConstraint -> PN+      pcName (PackageConstraint scope _) = scopeToPackageName scope++-- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display+-- in the error case.+--+-- When there is no solution, we produce the error message by rerunning the+-- solver but making it prefer the goals from the final conflict set from the+-- first run (or a subset of the final conflict set with+-- --minimize-conflict-set). We also set the backjump limit to 0, so that the+-- log stops at the first backjump and is relatively short. Preferring goals+-- from the final conflict set increases the probability that the log to the+-- first backjump contains package, flag, and stanza choices that are relevant+-- to the final failure. The solver shouldn't need to choose any packages that+-- aren't in the final conflict set. (For every variable in the final conflict+-- set, the final conflict set should also contain the variable that introduced+-- that variable. The solver can then follow that chain of variables in reverse+-- order from the user target to the conflict.) However, it is possible that the+-- conflict set contains unnecessary variables.+--+-- Producing an error message when the solver reaches the backjump limit is more+-- complicated. There is no final conflict set, so we create one for the minimal+-- subtree containing the path that the solver took to the first backjump. This+-- conflict set helps explain why the solver reached the backjump limit, because+-- the first backjump contributes to reaching the backjump limit. Additionally,+-- the solver is much more likely to be able to finish traversing this subtree+-- before the backjump limit, since its size is linear (not exponential) in the+-- number of goal choices. We create it by pruning all children after the first+-- successful child under each node in the original tree, so that there is at+-- most one valid choice at each level. Then we use the final conflict set from+-- that run to generate an error message, as in the case where the solver found+-- that there was no solution.+--+-- Using the full log from a rerun of the solver ensures that the log is+-- complete, i.e., it shows the whole chain of dependencies from the user+-- targets to the conflicting packages.+solve' :: SolverConfig+       -> CompilerInfo+       -> Index+       -> PkgConfigDb+       -> (PN -> PackagePreferences)+       -> Map PN [LabeledPackageConstraint]+       -> Set PN+       -> Progress String String (Assignment, RevDepMap)+solve' sc cinfo idx pkgConfigDB pprefs gcs pns =+    toProgress $ retry (runSolver printFullLog sc) createErrorMsg+  where+    runSolver :: Bool -> SolverConfig+              -> RetryLog String SolverFailure (Assignment, RevDepMap)+    runSolver keepLog sc' =+        displayLogMessages keepLog $+        solve sc' cinfo idx pkgConfigDB pprefs gcs pns++    createErrorMsg :: SolverFailure+                   -> RetryLog String String (Assignment, RevDepMap)+    createErrorMsg failure@(ExhaustiveSearch cs cm) =+      if asBool $ minimizeConflictSet sc+      then continueWith ("Found no solution after exhaustively searching the "+                          ++ "dependency tree. Rerunning the dependency solver "+                          ++ "to minimize the conflict set ({"+                          ++ showConflictSet cs ++ "}).") $+           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $+               \case+                  ExhaustiveSearch cs' cm' ->+                      fromProgress $ Fail $+                          rerunSolverForErrorMsg cs'+                       ++ finalErrorMsg sc (ExhaustiveSearch cs' cm')+                  BackjumpLimitReached ->+                      fromProgress $ Fail $+                          "Reached backjump limit while trying to minimize the "+                       ++ "conflict set to create a better error message. "+                       ++ "Original error message:\n"+                       ++ rerunSolverForErrorMsg cs+                       ++ finalErrorMsg sc failure+      else fromProgress $ Fail $+           rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure+    createErrorMsg failure@BackjumpLimitReached     =+        continueWith+             ("Backjump limit reached. Rerunning dependency solver to generate "+              ++ "a final conflict set for the search tree containing the "+              ++ "first backjump.") $+        retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $+            \case+               ExhaustiveSearch cs _ ->+                   fromProgress $ Fail $+                   rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure+               BackjumpLimitReached  ->+                   -- This case is possible when the number of goals involved in+                   -- conflicts is greater than the backjump limit.+                   fromProgress $ Fail $ finalErrorMsg sc failure+                    ++ "Failed to generate a summarized dependency solver "+                    ++ "log due to low backjump limit."++    rerunSolverForErrorMsg :: ConflictSet -> String+    rerunSolverForErrorMsg cs =+      let sc' = sc {+                    goalOrder = Just goalOrder'+                  , maxBackjumps = Just 0+                  }++          -- Preferring goals from the conflict set takes precedence over the+          -- original goal order.+          goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)++      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))++    printFullLog = solverVerbosity sc >= verbose++    messages :: Progress step fail done -> [step]+    messages = foldProgress (:) (const []) (const [])++-- | Try to remove variables from the given conflict set to create a minimal+-- conflict set.+--+-- Minimal means that no proper subset of the conflict set is also a conflict+-- set, though there may be other possible conflict sets with fewer variables.+-- This function minimizes the input by trying to remove one variable at a time.+-- It only makes one pass over the variables, so it runs the solver at most N+-- times when given a conflict set of size N. Only one pass is necessary,+-- because every superset of a conflict set is also a conflict set, meaning that+-- failing to remove variable X from a conflict set in one step means that X+-- cannot be removed from any subset of that conflict set in a subsequent step.+--+-- Example steps:+--+-- Start with {A, B, C}.+-- Try to remove A from {A, B, C} and fail.+-- Try to remove B from {A, B, C} and succeed.+-- Try to remove C from {A, C} and fail.+-- Return {A, C}+--+-- This function can fail for two reasons:+--+-- 1. The solver can reach the backjump limit on any run. In this case the+--    returned RetryLog ends with BackjumpLimitReached.+--    TODO: Consider applying the backjump limit to all solver runs combined,+--    instead of each individual run. For example, 10 runs with 10 backjumps+--    each should count as 100 backjumps.+-- 2. Since this function works by rerunning the solver, it is possible for the+--    solver to add new unnecessary variables to the conflict set. This function+--    discards the result from any run that adds new variables to the conflict+--    set, but the end result may not be completely minimized.+tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a)+                         -> SolverConfig+                         -> ConflictSet+                         -> ConflictMap+                         -> RetryLog String SolverFailure a+tryToMinimizeConflictSet runSolver sc cs cm =+    foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v)+          (fromProgress $ Fail $ ExhaustiveSearch cs cm)+          (CS.toList cs)+  where+    -- This function runs the solver and makes it prefer goals in the following+    -- order:+    --+    -- 1. variables in 'smallestKnownCS', excluding 'v'+    -- 2. 'v'+    -- 3. all other variables+    --+    -- If 'v' is not necessary, then the solver will find that there is no+    -- solution before starting to solve for 'v', and the new final conflict set+    -- will be very likely to not contain 'v'. If 'v' is necessary, the solver+    -- will most likely need to try solving for 'v' before finding that there is+    -- no solution, and the new final conflict set will still contain 'v'.+    -- However, this method isn't perfect, because it is possible for the solver+    -- to add new unnecessary variables to the conflict set on any run. This+    -- function prevents the conflict set from growing by checking that the new+    -- conflict set is a subset of the old one and falling back to using the old+    -- conflict set when that check fails.+    tryToRemoveOneVar :: Var QPN+                      -> ConflictSet+                      -> ConflictMap+                      -> RetryLog String SolverFailure a+    tryToRemoveOneVar v smallestKnownCS smallestKnownCM+        -- Check whether v is still present, because it may have already been+        -- removed in a previous solver rerun.+      | not (v `CS.member` smallestKnownCS) =+          fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM+      | otherwise =+        continueWith ("Trying to remove variable " ++ varStr ++ " from the "+                      ++ "conflict set.") $+        retry (runSolver sc') $ \case+            err@(ExhaustiveSearch cs' _)+              | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS ->+                  let msg = if not $ CS.member v cs'+                            then "Successfully removed " ++ varStr ++ " from "+                                  ++ "the conflict set."+                            else "Failed to remove " ++ varStr ++ " from the "+                                  ++ "conflict set."+                  in -- Use the new conflict set, even if v wasn't removed,+                     -- because other variables may have been removed.+                     failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err+              | otherwise ->+                  failWith ("Failed to find a smaller conflict set. The new "+                             ++ "conflict set is not a subset of the previous "+                             ++ "conflict set: " ++ showCS cs') $+                  ExhaustiveSearch smallestKnownCS smallestKnownCM+            BackjumpLimitReached ->+                failWith ("Reached backjump limit while minimizing conflict set.")+                         BackjumpLimitReached+      where+        varStr = "\"" ++ showVar v ++ "\""+        showCS cs' = "{" ++ showConflictSet cs' ++ "}"++        sc' = sc { goalOrder = Just goalOrder' }++        goalOrder' =+            preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS)+         <> preferGoal v+         <> fromMaybe mempty (goalOrder sc)++    -- Like 'retry', except that it only applies the input function when the+    -- backjump limit has not been reached.+    retryNoSolution :: RetryLog step SolverFailure done+                    -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)+                    -> RetryLog step SolverFailure done+    retryNoSolution lg f = retry lg $ \case+        ExhaustiveSearch cs' cm' -> f cs' cm'+        BackjumpLimitReached     -> fromProgress (Fail BackjumpLimitReached)++-- | Goal ordering that chooses goals contained in the conflict set before+-- other goals.+preferGoalsFromConflictSet :: ConflictSet+                           -> Variable QPN -> Variable QPN -> Ordering+preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs++-- | Goal ordering that chooses the given goal first.+preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering+preferGoal preferred = comparing $ \v -> toVar v /= preferred++toVar :: Variable QPN -> Var QPN+toVar (PackageVar qpn)    = P qpn+toVar (FlagVar    qpn fn) = F (FN qpn fn)+toVar (StanzaVar  qpn sn) = S (SN qpn sn)++finalErrorMsg :: SolverConfig -> SolverFailure -> String+finalErrorMsg sc failure =+    case failure of+      ExhaustiveSearch cs cm ->+          "After searching the rest of the dependency tree exhaustively, "+          ++ "these were the goals I've had most trouble fulfilling: "+          ++ showCS cm cs+          ++ flagSuggestion+        where+          showCS = if solverVerbosity sc > normal+                   then CS.showCSWithFrequency+                   else CS.showCSSortedByFrequency+          flagSuggestion =+              -- Don't suggest --minimize-conflict-set if the conflict set is+              -- already small, because it is unlikely to be reduced further.+              if CS.size cs > 3 && not (asBool (minimizeConflictSet sc))+              then "\nTry running with --minimize-conflict-set to improve the "+                    ++ "error message."+              else ""+      BackjumpLimitReached ->+          "Backjump limit reached (" ++ currlimit (maxBackjumps sc) +++          "change with --max-backjumps or try to run with --reorder-goals).\n"+        where currlimit (Just n) = "currently " ++ show n ++ ", "+              currlimit Nothing  = ""
+ cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs view
@@ -0,0 +1,94 @@+module Distribution.Solver.Modular.Assignment+    ( Assignment(..)+    , PAssignment+    , FAssignment+    , SAssignment+    , toCPs+    ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (pi)++import qualified Data.Array as A+import qualified Data.List as L+import qualified Data.Map as M++import Data.Maybe (fromJust)++import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal++import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath++import Distribution.Solver.Modular.Configured+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.LabeledGraph+import Distribution.Solver.Modular.Package++-- | A (partial) package assignment. Qualified package names+-- are associated with instances.+type PAssignment    = Map QPN I++type FAssignment    = Map QFN Bool+type SAssignment    = Map QSN Bool++-- | A (partial) assignment of variables.+data Assignment = A PAssignment FAssignment SAssignment+  deriving (Show, Eq)++-- | Delivers an ordered list of fully configured packages.+--+-- TODO: This function is (sort of) ok. However, there's an open bug+-- w.r.t. unqualification. There might be several different instances+-- of one package version chosen by the solver, which will lead to+-- clashes.+toCPs :: Assignment -> RevDepMap -> [CP QPN]+toCPs (A pa fa sa) rdm =+  let+    -- get hold of the graph+    g   :: Graph Component+    vm  :: Vertex -> ((), QPN, [(Component, QPN)])+    cvm :: QPN -> Maybe Vertex+    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.+    (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))+                                  (M.toList rdm))+    tg :: Graph Component+    tg = transposeG g+    -- Topsort the dependency graph, yielding a list of pkgs in the right order.+    -- The graph will still contain all the installed packages, and it might+    -- contain duplicates, because several variables might actually resolve to+    -- the same package in the presence of qualified package names.+    ps :: [PI QPN]+    ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $+         topSort g+    -- Determine the flags per package, by walking over and regrouping the+    -- complete flag assignment by package.+    fapp :: Map QPN FlagAssignment+    fapp = M.fromListWith mappend $+           L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $+           M.toList $+           fa+    -- Stanzas per package.+    sapp :: Map QPN OptionalStanzaSet+    sapp = M.fromListWith mappend+         $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty))+         $ M.toList sa+    -- Dependencies per package.+    depp :: QPN -> [(Component, PI QPN)]+    depp qpn = let v :: Vertex+                   v   = fromJust (cvm qpn) -- TODO: why this is safe?+                   dvs :: [(Component, Vertex)]+                   dvs = tg A.! v+               in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs+    -- Translated to PackageDeps+    depp' :: QPN -> ComponentDeps [PI QPN]+    depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp+  in+    L.map (\ pi@(PI qpn _) -> CP pi+                                 (M.findWithDefault mempty qpn fapp)+                                 (M.findWithDefault mempty qpn sapp)+                                 (depp' qpn))+          ps
+ cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.Builder (+    buildTree+  , splits -- for testing+  ) where++-- Building the search tree.+--+-- In this phase, we build a search tree that is too large, i.e, it contains+-- invalid solutions. We keep track of the open goals at each point. We+-- nondeterministically pick an open goal (via a goal choice node), create+-- subtrees according to the index and the available solutions, and extend the+-- set of open goals by superficially looking at the dependencies recorded in+-- the index.+--+-- For each goal, we keep track of all the *reasons* why it is being+-- introduced. These are for debugging and error messages, mainly. A little bit+-- of care has to be taken due to the way we treat flags. If a package has+-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we+-- store the entire dependency.++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set as S+import Prelude++import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import qualified Distribution.Solver.Modular.PSQ as P+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.ComponentDeps+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Settings++-- | All state needed to build and link the search tree. It has a type variable+-- because the linking phase doesn't need to know about the state used to build+-- the tree.+data Linker a = Linker {+  buildState   :: a,+  linkingState :: LinkingState+}++-- | The state needed to build the search tree without creating any linked nodes.+data BuildState = BS {+  index :: Index,                   -- ^ information about packages and their dependencies+  rdeps :: RevDepMap,               -- ^ set of all package goals, completed and open, with reverse dependencies+  open  :: [OpenGoal],              -- ^ set of still open goals (flag and package goals)+  next  :: BuildType,               -- ^ kind of node to generate next+  qualifyOptions :: QualifyOptions  -- ^ qualification options+}++-- | Map of available linking targets.+type LinkingState = M.Map (PN, I) [PackagePath]++-- | Extend the set of open goals with the new goals listed.+--+-- We also adjust the map of overall goals, and keep track of the+-- reverse dependencies of each of the goals.+extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState+extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs+  where+    go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState+    go g o []                                             = s { rdeps = g, open = o }+    go g o ((Flagged fn@(FN qpn _) fInfo t f)  : ngs) =+        go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs+      -- Note: for 'Flagged' goals, we always insert, so later additions win.+      -- This is important, because in general, if a goal is inserted twice,+      -- the later addition will have better dependency information.+    go g o ((Stanza sn@(SN qpn _) t)           : ngs) =+        go g (StanzaGoal sn t (flagGR qpn) : o) ngs+    go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs)+      | qpn == qpn'       =+            -- We currently only add a self-dependency to the graph if it is+            -- between a package and its setup script. The edge creates a cycle+            -- and causes the solver to backtrack and choose a different+            -- instance for the setup script. We may need to track other+            -- self-dependencies once we implement component-based solving.+          case c of+            ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs+            _              -> go                                                    g  o ngs+      | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs+      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (PkgGoal qpn (DependencyGoal dr) : o) ngs+          -- code above is correct; insert/adjust have different arg order+    go g o ((Simple (LDep _dr (Ext _ext )) _)  : ngs) = go g o ngs+    go g o ((Simple (LDep _dr (Lang _lang))_)  : ngs) = go g o ngs+    go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs++    addIfAbsent :: Eq a => a -> [a] -> [a]+    addIfAbsent x xs = if x `elem` xs then xs else x : xs++    -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by+    -- its containing package.+    flagGR :: qpn -> GoalReason qpn+    flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty)++-- | Given the current scope, qualify all the package names in the given set of+-- dependencies and then extend the set of open goals accordingly.+scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo ->+                    BuildState -> BuildState+scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s+  where+    -- Qualify all package names+    qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps+    -- Introduce all package flags+    qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs+    -- Combine new package and flag goals+    gs     = qfdefs ++ qfdeps+    -- NOTE:+    --+    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially+    -- multiple times, both via the flag declaration and via dependencies.++-- | 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 PInfo -- ^ build a tree for a concrete instance++build :: Linker BuildState -> Tree () QGoalReason+build = ana go+  where+    go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)+    go s = addLinking (linkingState s) $ addChildren (buildState s)++addChildren :: BuildState -> TreeF () QGoalReason BuildState++-- If we have a choice between many goals, we just record the choice in+-- the tree. We select each open goal in turn, and before we descend, remove+-- it from the queue of open goals.+addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })+  | L.null gs = DoneF rdm ()+  | otherwise = GoalChoiceF rdm $ P.fromList+                                $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' }))+                                $ splits gs++-- If we have already picked a goal, then the choice depends on the kind+-- of goal.+--+-- For a package, we look up the instances available in the global info,+-- and then handle each instance in turn.+addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) =+  case M.lookup pn idx of+    Nothing  -> FailF+                (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)+                UnknownPackage+    Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->+                                                       ([], POption i Nothing, bs { next = Instance qpn info }))+                                                     (M.toList pis)))+      -- TODO: data structure conversion is rather ugly here++-- For a flag, we create only two subtrees, and we create them in the order+-- that is indicated by the flag default.+addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) =+  FChoiceF qfn rdm gr weak m b (W.fromList+    [([if b then 0 else 1], True,  (extendOpen qpn t bs) { next = Goals }),+     ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })])+  where+    trivial = L.null t && L.null f+    weak = WeakOrTrivial $ unWeakOrTrivial w || trivial++-- For a stanza, we also create only two subtrees. The order is initially+-- False, True. This can be changed later by constraints (force enabling+-- the stanza by replacing the False branch with failure) or preferences+-- (try enabling the stanza if possible by moving the True branch first).++addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) =+  SChoiceF qsn rdm gr trivial (W.fromList+    [([0], False,                                                                  bs  { next = Goals }),+     ([1], True,  (extendOpen qpn t bs) { next = Goals })])+  where+    trivial = WeakOrTrivial (L.null t)++-- For a particular instance, we change the state: we update the scope,+-- and furthermore we update the set of goals.+--+-- TODO: We could inline this above.+addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) =+  addChildren ((scopedExtendOpen qpn fdeps fdefs bs)+         { next = Goals })++{-------------------------------------------------------------------------------+  Add linking+-------------------------------------------------------------------------------}++-- | Introduce link nodes into the tree+--+-- Linking is a phase that adapts package choice nodes and adds the option to+-- link wherever appropriate: Package goals are called "related" if they are for+-- the same instance of the same package (but have different prefixes). A link+-- option is available in a package choice node whenever we can choose an+-- instance that has already been chosen for a related goal at a higher position+-- in the tree. We only create link options for related goals that are not+-- themselves linked, because the choice to link to a linked goal is the same as+-- the choice to link to the target of that goal's linking.+--+-- The code here proceeds by maintaining a finite map recording choices that+-- have been made at higher positions in the tree. For each pair of package name+-- and instance, it stores the prefixes at which we have made a choice for this+-- package instance. Whenever we make an unlinked choice, we extend the map.+-- Whenever we find a choice, we look into the map in order to find out what+-- link options we have to add.+--+-- A separate tree traversal would be simpler. However, 'addLinking' creates+-- linked nodes from existing unlinked nodes, which leads to sharing between the+-- nodes. If we copied the nodes when they were full trees of type+-- 'Tree () QGoalReason', then the sharing would cause a space leak during+-- exploration of the tree. Instead, we only copy the 'BuildState', which is+-- relatively small, while the tree is being constructed. See+-- https://github.com/haskell/cabal/issues/2899+addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)+-- The only nodes of interest are package nodes+addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =+  let linkedCs = fmap (\bs -> Linker bs ls) $+                 W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)+      unlinkedCs = W.mapWithKey goP cs+      allCs = unlinkedCs `W.union` linkedCs++      -- Recurse underneath package choices. Here we just need to make sure+      -- that we record the package choice so that it is available below+      goP :: POption -> a -> Linker a+      goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls+      goP _                   _  = alreadyLinked+  in PChoiceF qpn rdm gr allCs+addLinking ls t = fmap (\bs -> Linker bs ls) t++linkChoices :: forall a w . LinkingState+            -> QPN+            -> (w, POption, a)+            -> [(w, POption, a)]+linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =+    L.map aux (M.findWithDefault [] (pn, i) related)+  where+    aux :: PackagePath -> (w, POption, a)+    aux pp = (weight, POption i (Just pp), subtree)+linkChoices _ _ (_, POption _ (Just _), _) =+    alreadyLinked++alreadyLinked :: a+alreadyLinked = error "addLinking called on tree that already contains linked nodes"++-------------------------------------------------------------------------------++-- | Interface to the tree builder. Just takes an index and a list of package names,+-- and computes the initial state and then the tree from there.+buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason+buildTree idx (IndependentGoals ind) igs =+    build Linker {+        buildState = BS {+            index = idx+          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)+          , open  = L.map topLevelGoal qpns+          , next  = Goals+          , qualifyOptions = defaultQualifyOptions idx+          }+      , linkingState = M.empty+      }+  where+    topLevelGoal qpn = PkgGoal qpn UserGoal++    qpns | ind       = L.map makeIndependent igs+         | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs++{-------------------------------------------------------------------------------+  Goals+-------------------------------------------------------------------------------}++-- | Information needed about a dependency before it is converted into a Goal.+data OpenGoal =+    FlagGoal   (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason+  | StanzaGoal (SN QPN)       (FlaggedDeps QPN)                   QGoalReason+  | PkgGoal    QPN                                                QGoalReason++-- | Closes a goal, i.e., removes all the extraneous information that we+-- need only during the build phase.+close :: OpenGoal -> Goal QPN+close (FlagGoal   qfn _ _ _ gr) = Goal (F qfn) gr+close (StanzaGoal qsn _     gr) = Goal (S qsn) gr+close (PkgGoal    qpn       gr) = Goal (P qpn) gr++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | Pairs each element of a list with the list resulting from removal of that+-- element from the original list.+splits :: [a] -> [(a, [a])]+splits = go id+  where+    go :: ([a] -> [a]) -> [a] -> [(a, [a])]+    go _ [] = []+    go f (x : xs) = (x, f xs) : go (f . (x :)) xs
+ cabal-install-solver/src/Distribution/Solver/Modular/Configured.hs view
@@ -0,0 +1,13 @@+module Distribution.Solver.Modular.Configured+    ( CP(..)+    ) where++import Distribution.PackageDescription (FlagAssignment)++import Distribution.Solver.Modular.Package+import Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import Distribution.Solver.Types.OptionalStanza++-- | A configured package is a package instance together with+-- a flag assignment and complete dependencies.+data CP qpn = CP (PI qpn) FlagAssignment OptionalStanzaSet (ComponentDeps [PI qpn])
+ cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs view
@@ -0,0 +1,72 @@+module Distribution.Solver.Modular.ConfiguredConversion+    ( convCP+    ) where++import Data.Maybe+import Prelude hiding (pi)+import Data.Either (partitionEithers)++import Distribution.Package (UnitId, packageId)++import qualified Distribution.Simple.PackageIndex as SI++import Distribution.Solver.Modular.Configured+import Distribution.Solver.Modular.Package++import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.PackageIndex as CI+import           Distribution.Solver.Types.PackagePath+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.InstSolverPackage+import           Distribution.Solver.Types.SourcePackage++-- | Converts from the solver specific result @CP QPN@ into+-- a 'ResolverPackage', which can then be converted into+-- the install plan.+convCP :: SI.InstalledPackageIndex ->+          CI.PackageIndex (SourcePackage loc) ->+          CP QPN -> ResolverPackage loc+convCP iidx sidx (CP qpi fa es ds) =+  case convPI qpi of+    Left  pi -> PreExisting $+                  InstSolverPackage {+                    instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi,+                    instSolverPkgLibDeps = fmap fst ds',+                    instSolverPkgExeDeps = fmap snd ds'+                  }+    Right pi -> Configured $+                  SolverPackage {+                      solverPkgSource = srcpkg,+                      solverPkgFlags = fa,+                      solverPkgStanzas = es,+                      solverPkgLibDeps = fmap fst ds',+                      solverPkgExeDeps = fmap snd ds'+                    }+      where+        srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi+  where+    ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -})+    ds' = fmap (partitionEithers . map convConfId) ds++convPI :: PI QPN -> Either UnitId PackageId+convPI (PI _ (I _ (Inst pi))) = Left pi+convPI pi                     = Right (packageId (either id id (convConfId pi)))++convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -}+convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) =+    case loc of+        Inst pi -> Left (PreExistingId sourceId pi)+        _otherwise+          | QualExe _ pn' <- q+          -- NB: the dependencies of the executable are also+          -- qualified.  So the way to tell if this is an executable+          -- dependency is to make sure the qualifier is pointing+          -- at the actual thing.  Fortunately for us, I was+          -- silly and didn't allow arbitrarily nested build-tools+          -- dependencies, so a shallow check works.+          , pn == pn' -> Right (PlannedId sourceId)+          | otherwise    -> Left  (PlannedId sourceId)+  where+    sourceId    = PackageIdentifier pn v
+ cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE CPP #-}+#ifdef DEBUG_CONFLICT_SETS+{-# LANGUAGE ImplicitParams #-}+#endif+-- | Conflict sets+--+-- Intended for double import+--+-- > import Distribution.Solver.Modular.ConflictSet (ConflictSet)+-- > import qualified Distribution.Solver.Modular.ConflictSet as CS+module Distribution.Solver.Modular.ConflictSet (+    ConflictSet -- opaque+  , Conflict(..)+  , ConflictMap+  , OrderedVersionRange(..)+#ifdef DEBUG_CONFLICT_SETS+  , conflictSetOrigin+#endif+  , showConflictSet+  , showCSSortedByFrequency+  , showCSWithFrequency+    -- Set-like operations+  , toSet+  , toList+  , union+  , unions+  , insert+  , delete+  , empty+  , singleton+  , singletonWithConflict+  , size+  , member+  , lookup+  , filter+  , fromList+  ) where++import Prelude hiding (lookup)+import Data.List (intercalate, sortBy)+import Data.Map (Map)+import Data.Set (Set)+import Data.Function (on)+import qualified Data.Map.Strict as M+import qualified Data.Set as S++#ifdef DEBUG_CONFLICT_SETS+import Data.Tree+import GHC.Stack+#endif++import Distribution.Solver.Modular.Var+import Distribution.Solver.Modular.Version+import Distribution.Solver.Types.PackagePath++-- | The set of variables involved in a solver conflict, each paired with+-- details about the conflict.+data ConflictSet = CS {+    -- | The set of variables involved in the conflict+    conflictSetToMap :: !(Map (Var QPN) (Set Conflict))++#ifdef DEBUG_CONFLICT_SETS+    -- | The origin of the conflict set+    --+    -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,+    -- we record the origin of every conflict set. For new conflict sets+    -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations+    -- that construct new conflict sets from existing conflict sets ('union',+    -- 'filter', ..)  we record the 'CallStack' to the call to the combinator+    -- as well as the 'CallStack's of the input conflict sets.+    --+    -- Requires @GHC >= 7.10@.+  , conflictSetOrigin :: Tree CallStack+#endif+  }+  deriving (Show)++-- | More detailed information about how a conflict set variable caused a+-- conflict. This information can be used to determine whether a second value+-- for that variable would lead to the same conflict.+--+-- TODO: Handle dependencies under flags or stanzas.+data Conflict =++    -- | The conflict set variable represents a package which depends on the+    -- specified problematic package. For example, the conflict set entry+    -- '(P x, GoalConflict y)' means that package x introduced package y, and y+    -- led to a conflict.+    GoalConflict QPN++    -- | The conflict set variable represents a package with a constraint that+    -- excluded the specified package and version. For example, the conflict set+    -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that+    -- package x's constraint on y excluded y-2.0.+  | VersionConstraintConflict QPN Ver++    -- | The conflict set variable represents a package that was excluded by a+    -- constraint from the specified package. For example, the conflict set+    -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))'+    -- means that package y's constraint 'x >= 2.0' excluded some version of x.+  | VersionConflict QPN OrderedVersionRange++    -- | Any other conflict.+  | OtherConflict+  deriving (Eq, Ord, Show)++-- | Version range with an 'Ord' instance.+newtype OrderedVersionRange = OrderedVersionRange VR+  deriving (Eq, Show)++-- TODO: Avoid converting the version ranges to strings.+instance Ord OrderedVersionRange where+  compare = compare `on` show++instance Eq ConflictSet where+  (==) = (==) `on` conflictSetToMap++instance Ord ConflictSet where+  compare = compare `on` conflictSetToMap++showConflictSet :: ConflictSet -> String+showConflictSet = intercalate ", " . map showVar . toList++showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String+showCSSortedByFrequency = showCS False++showCSWithFrequency :: ConflictMap -> ConflictSet -> String+showCSWithFrequency = showCS True++showCS :: Bool -> ConflictMap -> ConflictSet -> String+showCS showCount cm =+    intercalate ", " . map showWithFrequency . indexByFrequency+  where+    indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList+    showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of+      Just frequency+        | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")"+      _             -> showVar conflict++{-------------------------------------------------------------------------------+  Set-like operations+-------------------------------------------------------------------------------}++toSet :: ConflictSet -> Set (Var QPN)+toSet = M.keysSet . conflictSetToMap++toList :: ConflictSet -> [Var QPN]+toList = M.keys . conflictSetToMap++union ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  ConflictSet -> ConflictSet -> ConflictSet+union cs cs' = CS {+      conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs')+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])+#endif+    }++unions ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  [ConflictSet] -> ConflictSet+unions css = CS {+      conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc (map conflictSetOrigin css)+#endif+    }++insert ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Var QPN -> ConflictSet -> ConflictSet+insert var cs = CS {+      conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]+#endif+    }++delete :: Var QPN -> ConflictSet -> ConflictSet+delete var cs = CS {+      conflictSetToMap = M.delete var (conflictSetToMap cs)+    }++empty ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  ConflictSet+empty = CS {+      conflictSetToMap = M.empty+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++singleton ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Var QPN -> ConflictSet+singleton var = singletonWithConflict var OtherConflict++singletonWithConflict ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  Var QPN -> Conflict -> ConflictSet+singletonWithConflict var conflict = CS {+      conflictSetToMap = M.singleton var (S.singleton conflict)+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++size :: ConflictSet -> Int+size = M.size . conflictSetToMap++member :: Var QPN -> ConflictSet -> Bool+member var = M.member var . conflictSetToMap++lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict)+lookup var = M.lookup var . conflictSetToMap++fromList ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  [Var QPN] -> ConflictSet+fromList vars = CS {+      conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars]+#ifdef DEBUG_CONFLICT_SETS+    , conflictSetOrigin = Node ?loc []+#endif+    }++type ConflictMap = Map (Var QPN) Int+
+ cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TypeFamilies #-}+module Distribution.Solver.Modular.Cycles (+    detectCyclesPhase+  ) where++import Prelude hiding (cycle)+import qualified Data.Map as M+import qualified Data.Set as S++import qualified Distribution.Compat.Graph as G+import Distribution.Simple.Utils (ordNub)+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Types.ComponentDeps (Component)+import Distribution.Solver.Types.PackagePath++-- | Find and reject any nodes with cyclic dependencies+detectCyclesPhase :: Tree d c -> Tree d c+detectCyclesPhase = cata go+  where+    -- Only check children of choice nodes.+    go :: TreeF d c (Tree d c) -> Tree d c+    go (PChoiceF qpn rdm gr                         cs) =+        PChoice qpn rdm gr     $ fmap (checkChild qpn)   cs+    go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) =+        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs+    go (SChoiceF qsn@(SN qpn _) rdm gr w     cs) =+        SChoice qsn rdm gr w   $ fmap (checkChild qpn)   cs+    go x                                                = inn x++    checkChild :: QPN -> Tree d c -> Tree d c+    checkChild qpn x@(PChoice _  rdm _       _) = failIfCycle qpn rdm x+    checkChild qpn x@(FChoice _  rdm _ _ _ _ _) = failIfCycle qpn rdm x+    checkChild qpn x@(SChoice _  rdm _ _     _) = failIfCycle qpn rdm x+    checkChild qpn x@(GoalChoice rdm         _) = failIfCycle qpn rdm x+    checkChild _   x@(Fail _ _)                 = x+    checkChild qpn x@(Done       rdm _)         = failIfCycle qpn rdm x++    failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c+    failIfCycle qpn rdm x =+      case findCycles qpn rdm of+        Nothing     -> x+        Just relSet -> Fail relSet CyclicDependencies++-- | Given the reverse dependency map from a node in the tree, check+-- if the solution is cyclic. If it is, return the conflict set containing+-- all decisions that could potentially break the cycle.+--+-- TODO: The conflict set should also contain flag and stanza variables.+findCycles :: QPN -> RevDepMap -> Maybe ConflictSet+findCycles pkg rdm =+    -- This function has two parts: a faster cycle check that is called at every+    -- step and a slower calculation of the conflict set.+    --+    -- 'hasCycle' checks for cycles incrementally by only looking for cycles+    -- containing the current package, 'pkg'. It searches for cycles in the+    -- 'RevDepMap', which is the data structure used to store reverse+    -- dependencies in the search tree. We store the reverse dependencies in a+    -- map, because Data.Map is smaller and/or has better sharing than+    -- Distribution.Compat.Graph.+    --+    -- If there is a cycle, we call G.cycles to find a strongly connected+    -- component. Then we choose one cycle from the component to use for the+    -- conflict set. Choosing only one cycle can lead to a smaller conflict set,+    -- such as when a choice to enable testing introduces many cycles at once.+    -- In that case, all cycles contain the current package and are in one large+    -- strongly connected component.+    --+    if hasCycle+    then let scc :: G.Graph RevDepMapNode+             scc = case G.cycles $ revDepMapToGraph rdm of+                     []    -> findCyclesError "cannot find a strongly connected component"+                     c : _ -> G.fromDistinctList c++             next :: QPN -> QPN+             next p = case G.neighbors scc p of+                        Just (n : _) -> G.nodeKey n+                        _            -> findCyclesError "cannot find next node in the cycle"++             -- This function also assumes that all cycles contain 'pkg'.+             oneCycle :: [QPN]+             oneCycle = case iterate next pkg of+                          []     -> findCyclesError "empty cycle"+                          x : xs -> x : takeWhile (/= x) xs+         in Just $ CS.fromList $ map P oneCycle+    else Nothing+  where+    hasCycle :: Bool+    hasCycle = pkg `S.member` closure (neighbors pkg)++    closure :: [QPN] -> S.Set QPN+    closure = foldl go S.empty+      where+        go :: S.Set QPN -> QPN -> S.Set QPN+        go s x =+            if x `S.member` s+            then s+            else foldl go (S.insert x s) $ neighbors x++    neighbors :: QPN -> [QPN]+    neighbors x = case x `M.lookup` rdm of+                    Nothing -> findCyclesError "cannot find node"+                    Just xs -> map snd xs++    findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++)++data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)]++instance G.IsNode RevDepMapNode where+  type Key RevDepMapNode = QPN+  nodeKey (RevDepMapNode qpn _) = qpn+  nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns++revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode+revDepMapToGraph rdm = G.fromDistinctList+                       [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]
+ cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+module Distribution.Solver.Modular.Dependency (+    -- * Variables+    Var(..)+  , showVar+  , varPN+    -- * Conflict sets+  , ConflictSet+  , ConflictMap+  , CS.showConflictSet+    -- * Constrained instances+  , CI(..)+    -- * Flagged dependencies+  , FlaggedDeps+  , FlaggedDep(..)+  , LDep(..)+  , Dep(..)+  , PkgComponent(..)+  , ExposedComponent(..)+  , DependencyReason(..)+  , showDependencyReason+  , flattenFlaggedDeps+  , QualifyOptions(..)+  , qualifyDeps+  , unqualifyDeps+    -- * Reverse dependency map+  , RevDepMap+    -- * Goals+  , Goal(..)+  , GoalReason(..)+  , QGoalReason+  , goalToVar+  , varToConflictSet+  , goalReasonToConflictSet+  , goalReasonToConflictSetWithConflict+  , dependencyReasonToConflictSet+  , dependencyReasonToConflictSetWithVersionConstraintConflict+  , dependencyReasonToConflictSetWithVersionConflict+  ) where++import Prelude ()+import qualified Data.Map as M+import qualified Data.Set as S+import Distribution.Solver.Compat.Prelude hiding (pi)++import Language.Haskell.Extension (Extension(..), Language(..))++import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap)+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Var+import Distribution.Solver.Modular.Version+import qualified Distribution.Solver.Modular.ConflictSet as CS++import Distribution.Solver.Types.ComponentDeps (Component(..))+import Distribution.Solver.Types.PackagePath+import Distribution.Types.LibraryName+import Distribution.Types.PkgconfigVersionRange+import Distribution.Types.UnqualComponentName++{-------------------------------------------------------------------------------+  Constrained instances+-------------------------------------------------------------------------------}++-- | Constrained instance. It represents the allowed instances for a package,+-- which can be either a fixed instance or a version range.+data CI = Fixed I | Constrained VR+  deriving (Eq, Show)++{-------------------------------------------------------------------------------+  Flagged dependencies+-------------------------------------------------------------------------------}++-- | Flagged dependencies+--+-- 'FlaggedDeps' is the modular solver's view of a packages dependencies:+-- rather than having the dependencies indexed by component, each dependency+-- defines what component it is in.+--+-- Note that each dependency is associated with a Component. We must know what+-- component the dependencies belong to, or else we won't be able to construct+-- fine-grained reverse dependencies.+type FlaggedDeps qpn = [FlaggedDep qpn]++-- | Flagged dependencies can either be plain dependency constraints,+-- or flag-dependent dependency trees.+data FlaggedDep qpn =+    -- | Dependencies which are conditional on a flag choice.+    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)+    -- | Dependencies which are conditional on whether or not a stanza+    -- (e.g., a test suite or benchmark) is enabled.+  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)+    -- | Dependencies which are always enabled, for the component 'comp'.+  | Simple (LDep qpn) Component++-- | Conversatively flatten out flagged dependencies+--+-- NOTE: We do not filter out duplicates.+flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)]+flattenFlaggedDeps = concatMap aux+  where+    aux :: FlaggedDep qpn -> [(LDep qpn, Component)]+    aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f+    aux (Stanza  _   t)   = flattenFlaggedDeps t+    aux (Simple d c)      = [(d, c)]++type TrueFlaggedDeps  qpn = FlaggedDeps qpn+type FalseFlaggedDeps qpn = FlaggedDeps qpn++-- | A 'Dep' labeled with the reason it was introduced.+--+-- 'LDep' intentionally has no 'Functor' instance because the type variable+-- is used both to record the dependencies as well as who's doing the+-- depending; having a 'Functor' instance makes bugs where we don't distinguish+-- these two far too likely. (By rights 'LDep' ought to have two type variables.)+data LDep qpn = LDep (DependencyReason qpn) (Dep qpn)++-- | A dependency (constraint) associates a package name with a constrained+-- instance. It can also represent other types of dependencies, such as+-- dependencies on language extensions.+data Dep qpn = Dep (PkgComponent qpn) CI  -- ^ dependency on a package component+             | Ext Extension              -- ^ dependency on a language extension+             | Lang Language              -- ^ dependency on a language version+             | Pkg PkgconfigName PkgconfigVersionRange  -- ^ dependency on a pkg-config package+  deriving Functor++-- | An exposed component within a package. This type is used to represent+-- build-depends and build-tool-depends dependencies.+data PkgComponent qpn = PkgComponent qpn ExposedComponent+  deriving (Eq, Ord, Functor, Show)++-- | A component that can be depended upon by another package, i.e., a library+-- or an executable.+data ExposedComponent =+    ExposedLib LibraryName+  | ExposedExe UnqualComponentName+  deriving (Eq, Ord, Show)++-- | The reason that a dependency is active. It identifies the package and any+-- flag and stanza choices that introduced the dependency. It contains+-- everything needed for creating ConflictSets or describing conflicts in solver+-- log messages.+data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)+  deriving (Functor, Eq, Show)++-- | Print the reason that a dependency was introduced.+showDependencyReason :: DependencyReason QPN -> String+showDependencyReason (DependencyReason qpn flags stanzas) =+    intercalate " " $+        showQPN qpn+      : map (uncurry showFlagValue) (M.toList flags)+     ++ map (\s -> showSBool s True) (S.toList stanzas)++-- | Options for goal qualification (used in 'qualifyDeps')+--+-- See also 'defaultQualifyOptions'+data QualifyOptions = QO {+    -- | Do we have a version of base relying on another version of base?+    qoBaseShim :: Bool++    -- Should dependencies of the setup script be treated as independent?+  , qoSetupIndependent :: Bool+  }+  deriving Show++-- | Apply built-in rules for package qualifiers+--+-- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions',+-- it is important that these 'QualifyOptions' are _static_. Qualification+-- does NOT depend on flag assignment; in other words, it behaves the same no+-- matter which choices the solver makes (modulo the global 'QualifyOptions');+-- we rely on this in 'linkDeps' (see comment there).+--+-- NOTE: It's the _dependencies_ of a package that may or may not be independent+-- from the package itself. Package flag choices must of course be consistent.+qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN+qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go+  where+    go :: FlaggedDeps PN -> FlaggedDeps QPN+    go = map go1++    go1 :: FlaggedDep PN -> FlaggedDep QPN+    go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f)+    go1 (Stanza  sn     t)   = Stanza  (fmap (Q pp) sn)     (go t)+    go1 (Simple dep comp)    = Simple (goLDep dep comp) comp++    -- Suppose package B has a setup dependency on package A.+    -- This will be recorded as something like+    --+    -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion))+    --+    -- Observe that when we qualify this dependency, we need to turn that+    -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier+    -- to the DependencyReason.+    goLDep :: LDep PN -> Component -> LDep QPN+    goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp)++    goD :: Dep PN -> Component -> Dep QPN+    goD (Ext  ext)    _    = Ext  ext+    goD (Lang lang)   _    = Lang lang+    goD (Pkg pkn vr)  _    = Pkg pkn vr+    goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ =+        Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci+    goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp+      | qBase qpn   = Dep (Q (PackagePath ns (QualBase  pn)) <$> dep) ci+      | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci+      | otherwise   = Dep (Q (PackagePath ns inheritedQ    ) <$> dep) ci++    -- If P has a setup dependency on Q, and Q has a regular dependency on R, then+    -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup+    -- dependency on R. We do not do this for the base qualifier however.+    --+    -- The inherited qualifier is only used for regular dependencies; for setup+    -- and base deppendencies we override the existing qualifier. See #3160 for+    -- a detailed discussion.+    inheritedQ :: Qualifier+    inheritedQ = case q of+                   QualSetup _  -> q+                   QualExe _ _  -> q+                   QualToplevel -> q+                   QualBase _   -> QualToplevel++    -- Should we qualify this goal with the 'Base' package path?+    qBase :: PN -> Bool+    qBase dep = qoBaseShim && unPackageName dep == "base"++    -- Should we qualify this goal with the 'Setup' package path?+    qSetup :: Component -> Bool+    qSetup comp = qoSetupIndependent && comp == ComponentSetup++-- | Remove qualifiers from set of dependencies+--+-- This is used during link validation: when we link package @Q.A@ to @Q'.A@,+-- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute+-- what to link these dependencies to, we need to requalify @Q.B@ to become+-- @Q'.B@; we do this by first removing all qualifiers and then calling+-- 'qualifyDeps' again.+unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN+unqualifyDeps = go+  where+    go :: FlaggedDeps QPN -> FlaggedDeps PN+    go = map go1++    go1 :: FlaggedDep QPN -> FlaggedDep PN+    go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f)+    go1 (Stanza  sn     t)   = Stanza  (fmap unq sn)     (go t)+    go1 (Simple dep comp)    = Simple (goLDep dep) comp++    goLDep :: LDep QPN -> LDep PN+    goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep)++    unq :: QPN -> PN+    unq (Q _ pn) = pn++{-------------------------------------------------------------------------------+  Reverse dependency map+-------------------------------------------------------------------------------}++-- | A map containing reverse dependencies between qualified+-- package names.+type RevDepMap = Map QPN [(Component, QPN)]++{-------------------------------------------------------------------------------+  Goals+-------------------------------------------------------------------------------}++-- | A goal is just a solver variable paired with a reason.+-- The reason is only used for tracing.+data Goal qpn = Goal (Var qpn) (GoalReason qpn)+  deriving (Eq, Show, Functor)++-- | Reason why a goal is being added to a goal set.+data GoalReason qpn =+    UserGoal                              -- introduced by a build target+  | DependencyGoal (DependencyReason qpn) -- introduced by a package+  deriving (Eq, Show, Functor)++type QGoalReason = GoalReason QPN++goalToVar :: Goal a -> Var a+goalToVar (Goal v _) = v++-- | Compute a singleton conflict set from a 'Var'+varToConflictSet :: Var QPN -> ConflictSet+varToConflictSet = CS.singleton++-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal+-- leads to a conflict.+goalReasonToConflictSet :: GoalReason QPN -> ConflictSet+goalReasonToConflictSet UserGoal            = CS.empty+goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr++-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the+-- conflict occurred, namely the conflict set variables caused a conflict by+-- introducing the given package goal. See the documentation for 'GoalConflict'.+--+-- This function currently only specifies the reason for the conflict in the+-- simple case where the 'GoalReason' does not involve any flags or stanzas.+-- Otherwise, it falls back to calling 'goalReasonToConflictSet'.+goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet+goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas))+  | M.null flags && S.null stanzas =+      CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal+goalReasonToConflictSetWithConflict _    gr = goalReasonToConflictSet gr++-- | This function returns the solver variables responsible for the dependency.+-- It drops the values chosen for flag and stanza variables, which are only+-- needed for log messages.+dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet+dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) =+    CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas)+  where+    -- Filter out any flags that introduced the dependency with both values.+    -- They don't need to be included in the conflict set, because changing the+    -- flag value can't remove the dependency.+    flagVars :: [Var QPN]+    flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth]++    stanzaToVar :: Stanza -> Var QPN+    stanzaToVar = S . SN qpn++-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the+-- conflict occurred because the conflict set variables introduced a problematic+-- version constraint. See the documentation for 'VersionConstraintConflict'.+--+-- This function currently only specifies the reason for the conflict in the+-- simple case where the 'DependencyReason' does not involve any flags or+-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.+dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN+                                                           -> Ver+                                                           -> DependencyReason QPN+                                                           -> ConflictSet+dependencyReasonToConflictSetWithVersionConstraintConflict+    dependency excludedVersion dr@(DependencyReason qpn flags stanzas)+  | M.null flags && S.null stanzas =+    CS.singletonWithConflict (P qpn) $+    CS.VersionConstraintConflict dependency excludedVersion+  | otherwise = dependencyReasonToConflictSet dr++-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the+-- conflict occurred because the conflict set variables introduced a version of+-- a package that was excluded by a version constraint. See the documentation+-- for 'VersionConflict'.+--+-- This function currently only specifies the reason for the conflict in the+-- simple case where the 'DependencyReason' does not involve any flags or+-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.+dependencyReasonToConflictSetWithVersionConflict :: QPN+                                                 -> CS.OrderedVersionRange+                                                 -> DependencyReason QPN+                                                 -> ConflictSet+dependencyReasonToConflictSetWithVersionConflict+    pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas)+  | M.null flags && S.null stanzas =+    CS.singletonWithConflict (P qpn) $+    CS.VersionConflict pkgWithVersionConstraint constraint+  | otherwise = dependencyReasonToConflictSet dr
+ cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.Explore (backjumpAndExplore) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import qualified Distribution.Solver.Types.Progress as P++import qualified Data.List as L (foldl')+import qualified Data.Map.Strict as M+import qualified Data.Set as S++import Distribution.Simple.Setup (asBool)++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Log+import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.Package+import qualified Distribution.Solver.Modular.PSQ as P+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Settings+         (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..))+import Distribution.Types.VersionRange (anyVersion)++-- | This function takes the variable we're currently considering, a+-- last conflict set and a list of children's logs. Each log yields+-- either a solution or a conflict set. The result is a combined log for+-- the parent node that has explored a prefix of the children.+--+-- We can stop traversing the children's logs if we find an individual+-- conflict set that does not contain the current variable. In this+-- case, we can just lift the conflict set to the current level,+-- because the current level cannot possibly have contributed to this+-- conflict, so no other choice at the current level would avoid the+-- conflict.+--+-- If any of the children might contain a successful solution, we can+-- return it immediately. If all children contain conflict sets, we can+-- take the union as the combined conflict set.+--+-- The last conflict set corresponds to the justification that we+-- have to choose this goal at all. There is a reason why we have+-- introduced the goal in the first place, and this reason is in conflict+-- with the (virtual) option not to choose anything for the current+-- variable. See also the comments for 'avoidSet'.+--+-- We can also skip a child if it does not resolve any of the conflicts paired+-- with the current variable in the previous child's conflict set. 'backjump'+-- takes a function to determine whether a child can be skipped. If the child+-- can be skipped, the function returns a new conflict set to be merged with the+-- previous conflict set.+--+backjump :: forall w k a . Maybe Int+         -> EnableBackjumping+         -> FineGrainedConflicts++         -> (k -> S.Set CS.Conflict -> Maybe ConflictSet)+            -- ^ Function that determines whether the given choice could resolve+            --   the given conflict. It indicates false by returning 'Just',+            --   with the new conflicts to be added to the conflict set.++         -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a)+            -- ^ Function that logs the given choice that was skipped.++         -> Var QPN -- ^ The current variable.++         -> ConflictSet -- ^ Conflict set representing the reason that the goal+                        --   was introduced.++         -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a)+            -- ^ List of children's logs.++         -> ExploreState -> ConflictSetLog a+backjump mbj enableBj fineGrainedConflicts couldResolveConflicts+         logSkippedChoice var lastCS xs =+    foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing+  where+    combine :: (k, ExploreState -> ConflictSetLog a)+            -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a)+            ->  ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a+    combine (k, x) f csAcc mPreviousCS es =+        case (asBool fineGrainedConflicts, mPreviousCS) of+          (True, Just previousCS) ->+              case CS.lookup var previousCS of+                Just conflicts ->+                  case couldResolveConflicts k conflicts of+                    Nothing           -> retryNoSolution (x es) next+                    Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts)+                _              -> skipChoice previousCS+          _                       -> retryNoSolution (x es) next+      where+        next :: ConflictSet -> ExploreState -> ConflictSetLog a+        next !cs es' = if asBool enableBj && not (var `CS.member` cs)+                       then skipLoggingBackjump cs es'+                       else f (csAcc `CS.union` cs) (Just cs) es'++        -- This function is for skipping the choice when it cannot resolve any+        -- of the previous conflicts.+        skipChoice :: ConflictSet -> ConflictSetLog a+        skipChoice newCS =+            retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' ->+                f (csAcc `CS.union` cs') (Just cs') $++                -- Update the conflict map with the conflict set, to make up for+                -- skipping the whole subtree.+                es' { esConflictMap = updateCM cs' (esConflictMap es') }++    -- This function represents the option to not choose a value for this goal.+    avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a+    avoidGoal cs _mPreviousCS !es =+        logBackjump mbj (cs `CS.union` lastCS) $++        -- Use 'lastCS' below instead of 'cs' since we do not want to+        -- double-count the additionally accumulated conflicts.+        es { esConflictMap = updateCM lastCS (esConflictMap es) }++    -- The solver does not count or log backjumps at levels where the conflict+    -- set does not contain the current variable. Otherwise, there would be many+    -- consecutive log messages about backjumping with the same conflict set.+    skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a+    skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es)++-- | Creates a failing ConflictSetLog representing a backjump. It inserts a+-- "backjumping" message, checks whether the backjump limit has been reached,+-- and increments the backjump count.+logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a+logBackjump mbj cs es =+    failWith (Failure cs Backjump) $+        if reachedBjLimit (esBackjumps es)+        then BackjumpLimit+        else NoSolution cs es { esBackjumps = esBackjumps es + 1 }+  where+    reachedBjLimit = case mbj of+                       Nothing    -> const False+                       Just limit -> (>= limit)++-- | Like 'retry', except that it only applies the input function when the+-- backjump limit has not been reached.+retryNoSolution :: ConflictSetLog a+                -> (ConflictSet -> ExploreState -> ConflictSetLog a)+                -> ConflictSetLog a+retryNoSolution lg f = retry lg $ \case+    BackjumpLimit    -> fromProgress (P.Fail BackjumpLimit)+    NoSolution cs es -> f cs es++-- | The state that is read and written while exploring the search tree.+data ExploreState = ES {+    esConflictMap :: !ConflictMap+  , esBackjumps   :: !Int+  }++data IntermediateFailure =+    NoSolution ConflictSet ExploreState+  | BackjumpLimit++type ConflictSetLog = RetryLog Message IntermediateFailure++getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)+getBestGoal cm =+  P.maximumBy+    ( flip (M.findWithDefault 0) cm+    . (\ (Goal v _) -> v)+    )++getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a)+getFirstGoal ts =+  P.casePSQ ts+    (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error+    (\ k v _xs -> (k, v))  -- commit to the first goal choice++updateCM :: ConflictSet -> ConflictMap -> ConflictMap+updateCM cs cm =+  L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs)++-- | Record complete assignments on 'Done' nodes.+assign :: Tree d c -> Tree Assignment c+assign tree = cata go tree $ A M.empty M.empty M.empty+  where+    go :: TreeF d c (Assignment -> Tree Assignment c)+                 -> (Assignment -> Tree Assignment c)+    go (FailF c fr)            _                  = Fail c fr+    go (DoneF rdm _)           a                  = Done rdm a+    go (PChoiceF qpn rdm y       ts) (A pa fa sa) = PChoice qpn rdm y       $ W.mapWithKey f ts+        where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)+    go (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts+        where f k             r = r (A pa (M.insert qfn k fa) sa)+    go (SChoiceF qsn rdm y t     ts) (A pa fa sa) = SChoice qsn rdm y t     $ W.mapWithKey f ts+        where f k             r = r (A pa fa (M.insert qsn k sa))+    go (GoalChoiceF  rdm         ts) a            = GoalChoice  rdm         $ fmap ($ a) ts++-- | A tree traversal that simultaneously propagates conflict sets up+-- the tree from the leaves and creates a log.+exploreLog :: Maybe Int+           -> EnableBackjumping+           -> FineGrainedConflicts+           -> CountConflicts+           -> Index+           -> Tree Assignment QGoalReason+           -> ConflictSetLog (Assignment, RevDepMap)+exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t =+    para go t initES+  where+    getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)+    getBestGoal'+      | asBool countConflicts = \ ts cm -> getBestGoal cm ts+      | otherwise             = \ ts _  -> getFirstGoal ts++    go :: TreeF Assignment QGoalReason+                (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason)+                                    -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap))+    go (FailF c fr)                            = \ !es ->+        let es' = es { esConflictMap = updateCM c (esConflictMap es) }+        in failWith (Failure c fr) (NoSolution c es')+    go (DoneF rdm a)                           = \ _   -> succeedWith Success (a, rdm)+    go (PChoiceF qpn _ gr       ts)            =+      backjump mbj enableBj fineGrainedConflicts+               (couldResolveConflicts qpn)+               (logSkippedPackage qpn)+               (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,+               W.mapWithKey                    -- when descending ...+                 (\ k r es -> tryWith (TryP qpn k) (r es))+                 (fmap fst ts)+    go (FChoiceF qfn _ gr _ _ _ ts)            =+      backjump mbj enableBj fineGrainedConflicts+               (\_ _ -> Nothing)+               (const logSkippedChoiceSimple)+               (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,+               W.mapWithKey                    -- when descending ...+                 (\ k r es -> tryWith (TryF qfn k) (r es))+                 (fmap fst ts)+    go (SChoiceF qsn _ gr _     ts)            =+      backjump mbj enableBj fineGrainedConflicts+               (\_ _ -> Nothing)+               (const logSkippedChoiceSimple)+               (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,+               W.mapWithKey                    -- when descending ...+                 (\ k r es -> tryWith (TryS qsn k) (r es))+                 (fmap fst ts)+    go (GoalChoiceF _           ts)            = \ es ->+      let (k, (v, tree)) = getBestGoal' ts (esConflictMap es)+      in continueWith (Next k) $+         -- Goal choice nodes are normally not counted as backjumps, since the+         -- solver always explores exactly one choice, which means that the+         -- backjump from the goal choice would be redundant with the backjump+         -- from the PChoice, FChoice, or SChoice below. The one case where the+         -- backjump is not redundant is when the chosen goal is a failure node,+         -- so we log a backjump in that case.+         case tree of+           Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj+           _        -> v es++    initES = ES {+        esConflictMap = M.empty+      , esBackjumps = 0+      }++    -- Is it possible for this package instance (QPN and POption) to resolve any+    -- of the conflicts that were caused by the previous instance? The default+    -- is true, because it is always safe to explore a package instance.+    -- Skipping it is an optimization. If false, it returns a new conflict set+    -- to be merged with the previous one.+    couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet+    couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =+      let (PInfo deps _ _ _) = idx M.! pn M.! i+          qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps++          couldBeResolved :: CS.Conflict -> Maybe ConflictSet+          couldBeResolved CS.OtherConflict = Nothing+          couldBeResolved (CS.GoalConflict conflictingDep) =+              -- Check whether this package instance also has 'conflictingDep'+              -- as a dependency (ignoring flag and stanza choices).+              if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep]+              then Nothing+              else Just CS.empty+          couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) =+              -- Check whether this package instance also excludes version+              -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices).+              let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ]+                  vrIntersection = L.foldl' (.&&.) anyVersion vrs+              in if checkVR vrIntersection excludedVersion+                 then Nothing+                 else -- If we skip this package instance, we need to update the+                      -- conflict set to say that 'dep' was also excluded by+                      -- this package instance's constraint.+                      Just $ CS.singletonWithConflict (P dep) $+                      CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection)+          couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) =+              -- Check whether this package instance's version is also excluded+              -- by 'excludingVR'.+              if checkVR excludingVR v+              then Nothing+              else -- If we skip this version, we need to update the conflict+                   -- set to say that the reverse dependency also excluded this+                   -- version.+                   Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v)+      in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts)++    logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a+    logSkippedPackage qpn pOption cs es =+        tryWith (TryP qpn pOption) $+        failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $+        NoSolution cs es++    -- This function is used for flag and stanza choices, but it should not be+    -- called, because there is currently no way to skip a value for a flag or+    -- stanza.+    logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a+    logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es++-- | Build a conflict set corresponding to the (virtual) option not to+-- choose a solution for a goal at all.+--+-- In the solver, the set of goals is not statically determined, but depends+-- on the choices we make. Therefore, when dealing with conflict sets, we+-- always have to consider that we could perhaps make choices that would+-- avoid the existence of the goal completely.+--+-- Whenever we actually introduce a choice in the tree, we have already established+-- that the goal cannot be avoided. This is tracked in the "goal reason".+-- The choice to avoid the goal therefore is a conflict between the goal itself+-- and its goal reason. We build this set here, and pass it to the 'backjump'+-- function as the last conflict set.+--+-- This has two effects:+--+-- - In a situation where there are no choices available at all (this happens+-- if an unknown package is requested), the last conflict set becomes the+-- actual conflict set.+--+-- - In a situation where all of the children's conflict sets contain the+-- current variable, the goal reason of the current node will be added to the+-- conflict set.+--+avoidSet :: Var QPN -> QGoalReason -> ConflictSet+avoidSet var@(P qpn) gr =+  CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr)+avoidSet var         gr =+  CS.union (CS.singleton var) (goalReasonToConflictSet gr)++-- | Interface.+--+-- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing',+-- then infinitely many backjumps are allowed. If the limit is 'Just 0',+-- backtracking is completely disabled.+backjumpAndExplore :: Maybe Int+                   -> EnableBackjumping+                   -> FineGrainedConflicts+                   -> CountConflicts+                   -> Index+                   -> Tree d QGoalReason+                   -> RetryLog Message SolverFailure (Assignment, RevDepMap)+backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx =+    mapFailure convertFailure+  . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx+  . assign+  where+    convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es)+    convertFailure BackjumpLimit      = BackjumpLimitReached
+ cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Flag+    ( FInfo(..)+    , Flag+    , FlagInfo+    , FN(..)+    , QFN+    , QSN+    , Stanza+    , SN(..)+    , WeakOrTrivial(..)+    , FlagValue(..)+    , mkFlag+    , showQFN+    , showQFNBool+    , showFlagValue+    , showQSN+    , showQSNBool+    , showSBool+    ) where++import Data.Map as M+import Prelude hiding (pi)++import qualified Distribution.PackageDescription as P -- from Cabal++import Distribution.Solver.Types.Flag+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath++-- | Flag name. Consists of a package instance and the flag identifier itself.+data FN qpn = FN qpn Flag+  deriving (Eq, Ord, Show, Functor)++-- | Flag identifier. Just a string.+type Flag = P.FlagName++-- | Stanza identifier.+type Stanza = OptionalStanza++unFlag :: Flag -> String+unFlag = P.unFlagName++mkFlag :: String -> Flag+mkFlag = P.mkFlagName++-- | Flag info. Default value, whether the flag is manual, and+-- whether the flag is weak. Manual flags can only be set explicitly.+-- Weak flags are typically deferred by the solver.+data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial }+  deriving (Eq, Show)++-- | Flag defaults.+type FlagInfo = Map Flag FInfo++-- | Qualified flag name.+type QFN = FN QPN++-- | Stanza name. Paired with a package name, much like a flag.+data SN qpn = SN qpn Stanza+  deriving (Eq, Ord, Show, Functor)++-- | Qualified stanza name.+type QSN = SN QPN++-- | A property of flag and stanza choices that determines whether the+-- choice should be deferred in the solving process.+--+-- A 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.+--+-- 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 the choice.+newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }+  deriving (Eq, Ord, Show)++-- | Value shown for a flag in a solver log message. The message can refer to+-- only the true choice, only the false choice, or both choices.+data FlagValue = FlagTrue | FlagFalse | FlagBoth+  deriving (Eq, Show)++showQFNBool :: QFN -> Bool -> String+showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b++showQSNBool :: QSN -> Bool -> String+showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b++showFBool :: FN qpn -> Bool -> String+showFBool (FN _ f) v = P.showFlagValue (f, v)++-- | String representation of a flag-value pair.+showFlagValue :: P.FlagName -> FlagValue -> String+showFlagValue f FlagTrue  = '+' : unFlag f+showFlagValue f FlagFalse = '-' : unFlag f+showFlagValue f FlagBoth  = "+/-" ++ unFlag f++showSBool :: Stanza -> Bool -> String+showSBool s True  = "*" ++ showStanza s+showSBool s False = "!" ++ showStanza s++showQFN :: QFN -> String+showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f++showQSN :: QSN -> String+showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s
+ cabal-install-solver/src/Distribution/Solver/Modular/Index.hs view
@@ -0,0 +1,74 @@+module Distribution.Solver.Modular.Index+    ( Index+    , PInfo(..)+    , ComponentInfo(..)+    , IsVisible(..)+    , IsBuildable(..)+    , defaultQualifyOptions+    , mkIndex+    ) where++import Prelude hiding (pi)++import Data.Map (Map)+import qualified Data.List as L+import qualified Data.Map as M++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree++-- | An index contains information about package instances. This is a nested+-- dictionary. Package names are mapped to instances, which in turn is mapped+-- to info.+type Index = Map PN (Map I PInfo)++-- | Info associated with a package instance.+-- Currently, dependencies, component names, flags and failure reasons.+-- The component map records whether any components are unbuildable in the+-- current environment (compiler, os, arch, and global flag constraints).+-- Packages that have a failure reason recorded for them are disabled+-- globally, for reasons external to the solver. We currently use this+-- for shadowing which essentially is a GHC limitation, and for+-- installed packages that are broken.+data PInfo = PInfo (FlaggedDeps PN)+                   (Map ExposedComponent ComponentInfo)+                   FlagInfo+                   (Maybe FailReason)++-- | Info associated with each library and executable in a package instance.+data ComponentInfo = ComponentInfo {+    compIsVisible   :: IsVisible+  , compIsBuildable :: IsBuildable+  }+  deriving Show++-- | Whether a component is visible in the current environment.+newtype IsVisible = IsVisible Bool+  deriving (Eq, Show)++-- | Whether a component is made unbuildable by a "buildable: False" field.+newtype IsBuildable = IsBuildable Bool+  deriving (Eq, Show)++mkIndex :: [(PN, I, PInfo)] -> Index+mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs))++groupMap :: Ord a => [(a, b)] -> Map a [b]+groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs)++defaultQualifyOptions :: Index -> QualifyOptions+defaultQualifyOptions idx = QO {+      qoBaseShim         = or [ dep == base+                              | -- Find all versions of base ..+                                Just is <- [M.lookup base idx]+                                -- .. which are installed ..+                              , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is+                                -- .. and flatten all their dependencies ..+                              , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps+                              ]+    , qoSetupIndependent = True+    }+  where+    base = mkPackageName "base"
+ cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs view
@@ -0,0 +1,562 @@+module Distribution.Solver.Modular.IndexConversion+    ( convPIs+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import qualified Data.List as L+import qualified Data.Map.Strict as M+import qualified Distribution.Compat.NonEmptySet as NonEmptySet+import qualified Data.Set as S++import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Compiler+import Distribution.Package                          -- from Cabal+import Distribution.Simple.BuildToolDepends          -- from Cabal+import Distribution.Types.ExeDependency              -- from Cabal+import Distribution.Types.PkgconfigDependency        -- from Cabal+import Distribution.Types.ComponentName              -- from Cabal+import Distribution.Types.CondTree                   -- from Cabal+import Distribution.Types.MungedPackageId            -- from Cabal+import Distribution.Types.MungedPackageName          -- from Cabal+import Distribution.PackageDescription               -- from Cabal+import Distribution.PackageDescription.Configuration+import qualified Distribution.Simple.PackageIndex as SI+import Distribution.System++import           Distribution.Solver.Types.ComponentDeps+                   ( Component(..), componentNameToComponent )+import           Distribution.Solver.Types.Flag+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackageIndex as CI+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SourcePackage++import Distribution.Solver.Modular.Dependency as D+import Distribution.Solver.Modular.Flag as F+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version++-- | Convert both the installed package index and the source package+-- index into one uniform solver index.+--+-- We use 'allPackagesBySourcePackageId' for the installed package index+-- because that returns us several instances of the same package and version+-- in order of preference. This allows us in principle to \"shadow\"+-- packages if there are several installed packages of the same version.+-- There are currently some shortcomings in both GHC and Cabal in+-- 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 -> CompilerInfo -> Map PN [LabeledPackageConstraint]+        -> ShadowPkgs -> StrongFlags -> SolveExecutables+        -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)+        -> Index+convPIs os arch comp constraints sip strfl solveExes iidx sidx =+  mkIndex $+  convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx++-- | Convert a Cabal installed package index to the simpler,+-- more uniform index format of the solver.+convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)]+convIPI' (ShadowPkgs sip) idx =+    -- apply shadowing whenever there are multiple installed packages with+    -- the same version+    [ maybeShadow (convIP idx pkg)+    -- IMPORTANT to get internal libraries. See+    -- Note [Index conversion with internal libraries]+    | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx+    , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ]+  where++    -- shadowing is recorded in the package info+    shadow (pn, i, PInfo fdeps comps fds _)+      | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed))+    shadow x                                     = x++-- | Extract/recover the package ID from an installed package info, and convert it to a solver's I.+convId :: IPI.InstalledPackageInfo -> (PN, I)+convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi)+  where MungedPackageId mpn ver = mungedId ipi+        -- HACK. See Note [Index conversion with internal libraries]+        pn = encodeCompatPackageName mpn++-- | Convert a single installed package into the solver-specific format.+convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo)+convIP idx ipi =+  case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of+        Left u    -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u)))+        Right fds -> (pn, i, PInfo fds components M.empty Nothing)+ where+  -- TODO: Handle sub-libraries and visibility.+  components =+      M.singleton (ExposedLib LMainLibName)+                  ComponentInfo {+                      compIsVisible = IsVisible True+                    , compIsBuildable = IsBuildable True+                    }++  (pn, i) = convId ipi++  -- 'sourceLibName' is unreliable, but for now we only really use this for+  -- primary libs anyways+  comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi+-- TODO: Installed packages should also store their encapsulations!++-- Note [Index conversion with internal libraries]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Something very interesting happens when we have internal libraries+-- in our index.  In this case, we maybe have p-0.1, which itself+-- depends on the internal library p-internal ALSO from p-0.1.+-- Here's the danger:+--+--      - If we treat both of these packages as having PN "p",+--        then the solver will try to pick one or the other,+--        but never both.+--+--      - If we drop the internal packages, now p-0.1 has a+--        dangling dependency on an "installed" package we know+--        nothing about. Oops.+--+-- An expedient hack is to put p-internal into cabal-install's+-- index as a MUNGED package name, so that it doesn't conflict+-- with anyone else (except other instances of itself).  But+-- yet, we ought NOT to say that PNs in the solver are munged+-- package names, because they're not; for source packages,+-- we really will never see munged package names.+--+-- The tension here is that the installed package index is actually+-- per library, but the solver is per package.  We need to smooth+-- it over, and munging the package names is a pretty good way to+-- do it.++-- | Convert dependencies specified by an installed package id into+-- flagged dependencies of the solver.+--+-- May return Nothing if the package can't be found in the index. That+-- indicates that the original package having this dependency is broken+-- and should be ignored.+convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN)+convIPId dr comp idx ipid =+  case SI.lookupUnitId idx ipid of+    Nothing  -> Left ipid+    Just ipi -> let (pn, i) = convId ipi+                    name = ExposedLib LMainLibName  -- TODO: Handle sub-libraries.+                in  Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp)+                -- NB: something we pick up from the+                -- InstalledPackageIndex is NEVER an executable++-- | Convert a cabal-install source package index to the simpler,+-- more uniform index format of the solver.+convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]+         -> StrongFlags -> SolveExecutables+         -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]+convSPI' os arch cinfo constraints strfl solveExes =+    L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages++-- | Convert a single source package into the solver-specific format.+convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]+       -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)+convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =+  let i = I pv InRepo+      pkgConstraints = fromMaybe [] $ M.lookup pn constraints+  in  (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd)++-- We do not use 'flattenPackageDescription' or 'finalizePD'+-- from 'Distribution.PackageDescription.Configuration' here, because we+-- want to keep the condition tree, but simplify much of the test.++-- | Convert a generic package description to a solver-specific 'PInfo'.+convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]+        -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription+        -> PInfo+convGPD os arch cinfo constraints strfl solveExes pn+        (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) =+  let+    fds  = flagInfo strfl flags+++    conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN ->+            CondTree ConfVar [Dependency] a -> FlaggedDeps PN+    conv comp getInfo dr =+        convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes .+        addBuildableCondition getInfo++    initDR = DependencyReason pn M.empty S.empty++    flagged_deps+        = concatMap (\ds ->       conv ComponentLib         libBuildInfo        initDR ds) (maybeToList mlib)+       ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo        initDR ds) sub_libs+       ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm)   foreignLibBuildInfo initDR ds) flibs+       ++ concatMap (\(nm, ds) -> conv (ComponentExe nm)    buildInfo           initDR ds) exes+       ++ prefix (Stanza (SN pn TestStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentTest nm)   testBuildInfo (addStanza TestStanzas initDR) ds)+                    tests)+       ++ prefix (Stanza (SN pn BenchStanzas))+            (L.map  (\(nm, ds) -> conv (ComponentBench nm)  benchmarkBuildInfo (addStanza BenchStanzas initDR) ds)+                    benchs)+       ++ maybe []  (convSetupBuildInfo pn) (setupBuildInfo pkg)++    addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn+    addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss)++    -- | A too-new specVersion is turned into a global 'FailReason'+    -- which prevents the solver from selecting this release (and if+    -- forced to, emit a meaningful solver error message).+    fr = case scannedVersion of+        Just ver -> Just (UnsupportedSpecVer ver)+        Nothing  -> Nothing++    components :: Map ExposedComponent ComponentInfo+    components = M.fromList $ libComps ++ subLibComps ++ exeComps+      where+        libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib)+                   | lib <- maybeToList mlib ]+        subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib)+                      | (name, lib) <- sub_libs ]+        exeComps = [ ( ExposedExe name+                     , ComponentInfo {+                           compIsVisible = IsVisible True+                         , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False+                         }+                     )+                   | (name, exe) <- exes ]++        libToComponentInfo lib =+            ComponentInfo {+                compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True+              , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False+              }++        testCondition = testConditionForComponent os arch cinfo constraints++        isPrivate LibraryVisibilityPrivate = True+        isPrivate LibraryVisibilityPublic  = False++  in PInfo flagged_deps components fds fr++-- | Applies the given predicate (for example, testing buildability or+-- visibility) to the given component and environment. Values are combined with+-- AND. This function returns 'Nothing' when the result cannot be determined+-- before dependency solving. Additionally, this function only considers flags+-- that are set by unqualified flag constraints, and it doesn't check the+-- intra-package dependencies of a component.+testConditionForComponent :: OS+                          -> Arch+                          -> CompilerInfo+                          -> [LabeledPackageConstraint]+                          -> (a -> Bool)+                          -> CondTree ConfVar [Dependency] a+                          -> Maybe Bool+testConditionForComponent os arch cinfo constraints p tree =+    case go $ extractCondition p tree of+      Lit True  -> Just True+      Lit False -> Just False+      _         -> Nothing+  where+    flagAssignment :: [(FlagName, Bool)]+    flagAssignment =+        mconcat [ unFlagAssignment fa+                | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa)+                    <- L.map unlabelPackageConstraint constraints]++    -- Simplify the condition, using the current environment. Most of this+    -- function was copied from convBranch and+    -- Distribution.Types.Condition.simplifyCondition.+    go :: Condition ConfVar -> Condition ConfVar+    go (Var (OS os')) = Lit (os == os')+    go (Var (Arch arch')) = Lit (arch == arch')+    go (Var (Impl cf cvr))+        | matchImpl (compilerInfoId cinfo) ||+              -- fixme: Nothing should be treated as unknown, rather than empty+              --        list. This code should eventually be changed to either+              --        support partial resolution of compiler flags or to+              --        complain about incompletely configured compilers.+          any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True+        | otherwise = Lit False+      where+        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv+    go (Var (PackageFlag f))+        | Just b <- L.lookup f flagAssignment = Lit b+    go (Var v) = Var v+    go (Lit b) = Lit b+    go (CNot c) =+        case go c of+          Lit True -> Lit False+          Lit False -> Lit True+          c' -> CNot c'+    go (COr c d) =+        case (go c, go d) of+          (Lit False, d') -> d'+          (Lit True, _)   -> Lit True+          (c', Lit False) -> c'+          (_, Lit True)   -> Lit True+          (c', d')        -> COr c' d'+    go (CAnd c d) =+        case (go c, go d) of+          (Lit False, _) -> Lit False+          (Lit True, d') -> d'+          (_, Lit False) -> Lit False+          (c', Lit True) -> c'+          (c', d')       -> CAnd c' d'++-- | Create a flagged dependency tree from a list @fds@ of flagged+-- dependencies, using @f@ to form the tree node (@f@ will be+-- something like @Stanza sn@).+prefix :: (FlaggedDeps qpn -> FlaggedDep qpn)+       -> [FlaggedDeps qpn] -> FlaggedDeps qpn+prefix _ []  = []+prefix f fds = [f (concat fds)]++-- | Convert flag information. Automatic flags are now considered weak+-- unless strong flags have been selected explicitly.+flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo+flagInfo (StrongFlags strfl) =+    M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m)))+  where+    weak m = WeakOrTrivial $ not (strfl || m)+    flagType m = if m then Manual else Automatic++-- | Convert condition trees to flagged dependencies.  Mutually+-- recursive with 'convBranch'.  See 'convBranch' for an explanation+-- of all arguments preceding the input 'CondTree'.+convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo ->+                Component ->+                (a -> BuildInfo) ->+                SolveExecutables ->+                CondTree ConfVar [Dependency] a -> FlaggedDeps PN+convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =+             -- Merge all library and build-tool dependencies at every level in+             -- the tree of flagged dependencies. Otherwise 'extractCommon'+             -- could create duplicate dependencies, and the number of+             -- duplicates could grow exponentially from the leaves to the root+             -- of the tree.+             mergeSimpleDeps $+                 [ D.Simple singleDep comp+                 | dep <- ds+                 , singleDep <- convLibDeps dr dep ]  -- unconditional package dependencies++              ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (allExtensions bi) -- unconditional extension dependencies+              ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages  bi) -- unconditional language dependencies+              ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies+              ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches+              -- build-tools dependencies+              -- NB: Only include these dependencies if SolveExecutables+              -- is True.  It might be false in the legacy solver+              -- codepath, in which case there won't be any record of+              -- an executable we need.+              ++ [ D.Simple (convExeDep dr exeDep) comp+                 | solveExes'+                 , exeDep <- getAllToolDependencies pkg bi+                 , not $ isInternal pkg exeDep+                 ]+  where+    bi = getInfo info++data SimpleFlaggedDepKey qpn =+    SimpleFlaggedDepKey (PkgComponent qpn) Component+  deriving (Eq, Ord)++data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR++-- | Merge 'Simple' dependencies that apply to the same library or build-tool.+-- This function should be able to merge any two dependencies that can be merged+-- by extractCommon, in order to prevent the exponential growth of dependencies.+--+-- Note that this function can merge dependencies that have different+-- DependencyReasons, which can make the DependencyReasons less precise. This+-- loss of precision only affects performance and log messages, not correctness.+-- However, when 'mergeSimpleDeps' is only called on dependencies at a single+-- location in the dependency tree, the only difference between+-- DependencyReasons should be flags that have value FlagBoth. Adding extra+-- flags with value FlagBoth should not affect performance, since they are not+-- added to the conflict set. The only downside is the possibility of the log+-- incorrectly saying that the flag contributed to excluding a specific version+-- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB+-- introduces pkg <5, the merged dependency would mean that+-- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply+-- that +/-flagA excludes pkg-6.+mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn+mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged+  where+    (merged, unmerged) = L.foldl' f (M.empty, []) deps+      where+        f :: Ord qpn+          => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)+          -> FlaggedDep qpn+          -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn)+        f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) =+            ( M.insertWith mergeValues+                           (SimpleFlaggedDepKey dep comp)+                           (SimpleFlaggedDepValue dr vr)+                           merged'+            , unmerged')+        f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged')++        mergeValues :: SimpleFlaggedDepValue qpn+                    -> SimpleFlaggedDepValue qpn+                    -> SimpleFlaggedDepValue qpn+        mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) =+            SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2)++    toFlaggedDep :: SimpleFlaggedDepKey qpn+                 -> SimpleFlaggedDepValue qpn+                 -> FlaggedDep qpn+    toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) =+        D.Simple (LDep dr (Dep dep (Constrained vr))) comp++-- | Branch interpreter.  Mutually recursive with 'convCondTree'.+--+-- Here, we try to simplify one of Cabal's condition tree branches into the+-- solver's flagged dependency format, which is weaker. Condition trees can+-- contain complex logical expression composed from flag choices and special+-- flags (such as architecture, or compiler flavour). We try to evaluate the+-- special flags and subsequently simplify to a tree that only depends on+-- simple flag choices.+--+-- This function takes a number of arguments:+--+--      1. A map of flag values that have already been chosen. It allows+--         convBranch to avoid creating nested FlaggedDeps that are+--         controlled by the same flag and avoid creating DependencyReasons with+--         conflicting values for the same flag.+--+--      2. The DependencyReason calculated at this point in the tree of+--         conditionals. The flag values in the DependencyReason are similar to+--         the values in the map above, except for the use of FlagBoth.+--+--      3. Some pre dependency-solving known information ('OS', 'Arch',+--         'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables,+--+--      4. The package name @'PN'@ which this condition tree+--         came from, so that we can correctly associate @flag()@+--         variables with the correct package name qualifier,+--+--      5. The flag defaults 'FlagInfo' so that we can populate+--         'Flagged' dependencies with 'FInfo',+--+--      6. The name of the component 'Component' so we can record where+--         the fine-grained information about where the component came+--         from (see 'convCondTree'), and+--+--      7. A selector to extract the 'BuildInfo' from the leaves of+--         the 'CondTree' (which actually contains the needed+--         dependency information.)+--+--      8. The set of package names which should be considered internal+--         dependencies, and thus not handled as dependencies.+convBranch :: Map FlagName Bool+           -> DependencyReason PN+           -> PackageDescription+           -> OS+           -> Arch+           -> CompilerInfo+           -> PN+           -> FlagInfo+           -> Component+           -> (a -> BuildInfo)+           -> SolveExecutables+           -> CondBranch ConfVar [Dependency] a+           -> FlaggedDeps PN+convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') =+    go c'+       (\flags' dr' ->           convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes  t')+       (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf')+       flags dr+  where+    go :: Condition ConfVar+       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)+       -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN)+       ->  Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN+    go (Lit True)  t _ = t+    go (Lit False) _ f = f+    go (CNot c)    t f = go c f t+    go (CAnd c d)  t f = go c (go d t f) f+    go (COr  c d)  t f = go c t (go d t f)+    go (Var (PackageFlag fn)) t f = \flags' ->+        case M.lookup fn flags' of+          Just True  -> t flags'+          Just False -> f flags'+          Nothing    -> \dr' ->+            -- Add each flag to the DependencyReason for all dependencies below,+            -- including any extracted dependencies. Extracted dependencies are+            -- introduced by both flag values (FlagBoth). Note that we don't+            -- actually need to add the flag to the extracted dependencies for+            -- correct backjumping; the information only improves log messages+            -- by giving the user the full reason for each dependency.+            let addFlagValue v = addFlagToDependencyReason fn v dr'+                addFlag v = M.insert fn v flags'+            in extractCommon (t (addFlag True)  (addFlagValue FlagBoth))+                             (f (addFlag False) (addFlagValue FlagBoth))+                ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True)  (addFlagValue FlagTrue))+                                                     (f (addFlag False) (addFlagValue FlagFalse)) ]+    go (Var (OS os')) t f+      | os == os'      = t+      | otherwise      = f+    go (Var (Arch arch')) t f+      | arch == arch'  = t+      | otherwise      = f+    go (Var (Impl cf cvr)) t f+      | matchImpl (compilerInfoId cinfo) ||+            -- fixme: Nothing should be treated as unknown, rather than empty+            --        list. This code should eventually be changed to either+            --        support partial resolution of compiler flags or to+            --        complain about incompletely configured compilers.+        any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t+      | otherwise      = f+      where+        matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv++    addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn+    addFlagToDependencyReason fn v (DependencyReason pn' fs ss) =+        DependencyReason pn' (M.insert fn v fs) ss++    -- If both branches contain the same package as a simple dep, we lift it to+    -- the next higher-level, but with the union of version ranges. This+    -- heuristic together with deferring flag choices will then usually first+    -- resolve this package, and try an already installed version before imposing+    -- a default flag choice that might not be what we want.+    --+    -- Note that we make assumptions here on the form of the dependencies that+    -- can occur at this point. In particular, no occurrences of Fixed, as all+    -- dependencies below this point have been generated using 'convLibDep'.+    --+    -- WARNING: This is quadratic!+    extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn+    extractCommon ps ps' =+        -- Union the DependencyReasons, because the extracted dependency can be+        -- avoided by removing the dependency from either side of the+        -- conditional.+        [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp+        | D.Simple (LDep vs1                (Dep dep1 (Constrained vr1))) _ <- ps+        , D.Simple (LDep vs2                (Dep dep2 (Constrained vr2))) _ <- ps'+        , dep1 == dep2+        ]++-- | Merge DependencyReasons by unioning their variables.+unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn+unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) =+    DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2)++-- | Convert a Cabal dependency on a set of library components (from a single+-- package) to solver-specific dependencies.+convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN]+convLibDeps dr (Dependency pn vr libs) =+    [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr)+    | lib <- NonEmptySet.toList libs ]++-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency.+convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN+convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr)++-- | Convert setup dependencies+convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN+convSetupBuildInfo pn nfo =+    [ D.Simple singleDep ComponentSetup+    | dep <- setupDepends nfo+    , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ]
+ cabal-install-solver/src/Distribution/Solver/Modular/LabeledGraph.hs view
@@ -0,0 +1,117 @@+-- | Wrapper around Data.Graph with support for edge labels+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.LabeledGraph (+    -- * Graphs+    Graph+  , Vertex+    -- ** Building graphs+  , graphFromEdges+  , graphFromEdges'+  , buildG+  , transposeG+    -- ** Graph properties+  , vertices+  , edges+    -- ** Operations on the underlying unlabeled graph+  , forgetLabels+  , topSort+  ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Data.Array+import Data.Graph (Vertex, Bounds)+import qualified Data.Graph as G++{-------------------------------------------------------------------------------+  Types+-------------------------------------------------------------------------------}++type Graph e = Array Vertex [(e, Vertex)]+type Edge  e = (Vertex, e, Vertex)++{-------------------------------------------------------------------------------+  Building graphs+-------------------------------------------------------------------------------}++-- | Construct an edge-labeled graph+--+-- This is a simple adaptation of the definition in Data.Graph+graphFromEdges :: forall key node edge. Ord key+               => [ (node, key, [(edge, key)]) ]+               -> ( Graph edge+                  , Vertex -> (node, key, [(edge, key)])+                  , key -> Maybe Vertex+                  )+graphFromEdges edges0 =+    (graph, \v -> vertex_map ! v, key_vertex)+  where+    max_v        = length edges0 - 1+    bounds0      = (0, max_v) :: (Vertex, Vertex)+    sorted_edges = sortBy lt edges0+    edges1       = zip [0..] sorted_edges++    graph        = array bounds0 [(v, (mapMaybe mk_edge ks))+                                 | (v, (_, _, ks)) <- edges1]+    key_map      = array bounds0 [(v, k                    )+                                 | (v, (_, k, _ )) <- edges1]+    vertex_map   = array bounds0 edges1++    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2++    mk_edge :: (edge, key) -> Maybe (edge, Vertex)+    mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v)++    --  returns Nothing for non-interesting vertices+    key_vertex :: key -> Maybe Vertex+    key_vertex k = findVertex 0 max_v+      where+        findVertex a b+          | a > b     = Nothing+          | otherwise = case compare k (key_map ! mid) of+              LT -> findVertex a (mid-1)+              EQ -> Just mid+              GT -> findVertex (mid+1) b+          where+            mid = a + (b - a) `div` 2++graphFromEdges' :: Ord key+                => [ (node, key, [(edge, key)]) ]+                -> ( Graph edge+                   , Vertex -> (node, key, [(edge, key)])+                   )+graphFromEdges' x = (a,b)+  where+    (a,b,_) = graphFromEdges x++transposeG :: Graph e -> Graph e+transposeG g = buildG (bounds g) (reverseE g)++buildG :: Bounds -> [Edge e] -> Graph e+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)+  where+    reassoc (v, e, w) = (v, (e, w))++reverseE :: Graph e -> [Edge e]+reverseE g = [ (w, e, v) | (v, e, w) <- edges g ]++{-------------------------------------------------------------------------------+  Graph properties+-------------------------------------------------------------------------------}++vertices :: Graph e -> [Vertex]+vertices = indices++edges :: Graph e -> [Edge e]+edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ]++{-------------------------------------------------------------------------------+  Operations on the underlying unlabelled graph+-------------------------------------------------------------------------------}++forgetLabels :: Graph e -> G.Graph+forgetLabels = fmap (map snd)++topSort :: Graph e -> [Vertex]+topSort = G.topSort . forgetLabels
+ cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs view
@@ -0,0 +1,519 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- TODO: remove this+{-# OPTIONS -fno-warn-incomplete-uni-patterns #-}+module Distribution.Solver.Modular.Linking (+    validateLinking+  ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (get,put)++import Control.Exception (assert)+import Control.Monad.Reader+import Control.Monad.State+import Data.Map ((!))+import qualified Data.Map         as M+import qualified Data.Set         as S+import qualified Data.Traversable as T++import Distribution.Client.Utils.Assertion+import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath+import Distribution.Types.Flag (unFlagName)++{-------------------------------------------------------------------------------+  Validation++  Validation of links is a separate pass that's performed after normal+  validation. Validation of links checks that if the tree indicates that a+  package is linked, then everything underneath that choice really matches the+  package we have linked to.++  This is interesting because it isn't unidirectional. Consider that we've+  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.+  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that+  a.bar and b.bar are also linked. However, it's not required that we actually+  choose a.bar before b.bar. Goal choice order is relatively free. It's possible+  that we choose a.bar first, but also possible that we choose b.bar first. In+  both cases, we have to recognize that we have freedom of choice for the first+  of the two, but no freedom of choice for the second.++  This is what LinkGroups are all about. Using LinkGroup, we can record (in the+  situation above) that a.bar and b.bar need to be linked even if we haven't+  chosen either of them yet.+-------------------------------------------------------------------------------}++data ValidateState = VS {+      vsIndex    :: Index+    , vsLinks    :: Map QPN LinkGroup+    , vsFlags    :: FAssignment+    , vsStanzas  :: SAssignment+    , vsQualifyOptions :: QualifyOptions++    -- Saved qualified dependencies. Every time 'validateLinking' makes a+    -- package choice, it qualifies the package's dependencies and saves them in+    -- this map. Then the qualified dependencies are available for subsequent+    -- flag and stanza choices for the same package.+    , vsSaved    :: Map QPN (FlaggedDeps QPN)+    }++type Validate = Reader ValidateState++-- | Validate linked packages+--+-- Verify that linked packages have+--+-- * Linked dependencies,+-- * Equal flag assignments+-- * Equal stanza assignments+validateLinking :: Index -> Tree d c -> Tree d c+validateLinking index = (`runReader` initVS) . cata go+  where+    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)++    go (PChoiceF qpn rdm gr       cs) =+      PChoice qpn rdm gr       <$> T.sequence (W.mapWithKey (goP qpn) cs)+    go (FChoiceF qfn rdm gr t m d cs) =+      FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs)+    go (SChoiceF qsn rdm gr t     cs) =+      SChoice qsn rdm gr t     <$> T.sequence (W.mapWithKey (goS qsn) cs)++    -- For the other nodes we just recurse+    go (GoalChoiceF rdm           cs) = GoalChoice rdm <$> T.sequence cs+    go (DoneF revDepMap s)            = return $ Done revDepMap s+    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason++    -- Package choices+    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)+    goP qpn@(Q _pp pn) opt@(POption i _) r = do+      vs <- ask+      let PInfo deps _ _ _ = vsIndex vs ! pn ! i+          qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps+          newSaved         = M.insert qpn qdeps (vsSaved vs)+      case execUpdateState (pickPOption qpn opt qdeps) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs' { vsSaved = newSaved }) r++    -- Flag choices+    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goF qfn b r = do+      vs <- ask+      case execUpdateState (pickFlag qfn b) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs') r++    -- Stanza choices (much the same as flag choices)+    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goS qsn b r = do+      vs <- ask+      case execUpdateState (pickStanza qsn b) vs of+        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)+        Right vs'       -> local (const vs') r++    initVS :: ValidateState+    initVS = VS {+        vsIndex   = index+      , vsLinks   = M.empty+      , vsFlags   = M.empty+      , vsStanzas = M.empty+      , vsQualifyOptions = defaultQualifyOptions index+      , vsSaved   = M.empty+      }++{-------------------------------------------------------------------------------+  Updating the validation state+-------------------------------------------------------------------------------}++type Conflict = (ConflictSet, String)++newtype UpdateState a = UpdateState {+    unUpdateState :: StateT ValidateState (Either Conflict) a+  }+  deriving (Functor, Applicative, Monad)++instance MonadState ValidateState UpdateState where+  get    = UpdateState $ get+  put st = UpdateState $ do+             expensiveAssert (lgInvariant $ vsLinks st) $ return ()+             put st++lift' :: Either Conflict a -> UpdateState a+lift' = UpdateState . lift++conflict :: Conflict -> UpdateState a+conflict = lift' . Left++execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState+execUpdateState = execStateT . unUpdateState++pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()+pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i+pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps++pickConcrete :: QPN -> I -> UpdateState ()+pickConcrete qpn@(Q pp _) i = do+    vs <- get+    case M.lookup qpn (vsLinks vs) of+      -- Package is not yet in a LinkGroup. Create a new singleton link group.+      Nothing -> do+        let lg = lgSingleton qpn (Just $ PI pp i)+        updateLinkGroup lg++      -- Package is already in a link group. Since we are picking a concrete+      -- instance here, it must by definition be the canonical package.+      Just lg ->+        makeCanonical lg qpn i++pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()+pickLink qpn@(Q _pp pn) i pp' deps = do+    vs <- get++    -- The package might already be in a link group+    -- (because one of its reverse dependencies is)+    let lgSource = case M.lookup qpn (vsLinks vs) of+                     Nothing -> lgSingleton qpn Nothing+                     Just lg -> lg++    -- Find the link group for the package we are linking to+    --+    -- Since the builder never links to a package without having first picked a+    -- concrete instance for that package, and since we create singleton link+    -- groups for concrete instances, this link group must exist (and must+    -- in fact already have a canonical member).+    let target   = Q pp' pn+        lgTarget = vsLinks vs ! target++    -- Verify here that the member we add is in fact for the same package and+    -- matches the version of the canonical instance. However, violations of+    -- these checks would indicate a bug in the linker, not a true conflict.+    let sanityCheck :: Maybe (PI PackagePath) -> Bool+        sanityCheck Nothing              = False+        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI+    assert (sanityCheck (lgCanon lgTarget)) $ return ()++    -- Merge the two link groups (updateLinkGroup will propagate the change)+    lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget+    updateLinkGroup lgTarget'++    -- Make sure all dependencies are linked as well+    linkDeps target deps++makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()+makeCanonical lg qpn@(Q pp _) i =+    case lgCanon lg of+      -- There is already a canonical member. Fail.+      Just _ ->+        conflict ( CS.insert (P qpn) (lgConflictSet lg)+                 ,    "cannot make " ++ showQPN qpn+                   ++ " canonical member of " ++ showLinkGroup lg+                 )+      Nothing -> do+        let lg' = lg { lgCanon = Just (PI pp i) }+        updateLinkGroup lg'++-- | Link the dependencies of linked parents.+--+-- When we decide to link one package against another we walk through the+-- package's direct depedencies and make sure that they're all linked to each+-- other by merging their link groups (or creating new singleton link groups if+-- they don't have link groups yet). We do not need to do this recursively,+-- because having the direct dependencies in a link group means that we must+-- have already made or will make sooner or later a link choice for one of these+-- as well, and cover their dependencies at that point.+linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()+linkDeps target = \deps -> do+    -- linkDeps is called in two places: when we first link one package to+    -- another, and when we discover more dependencies of an already linked+    -- package after doing some flag assignment. It is therefore important that+    -- flag assignments cannot influence _how_ dependencies are qualified;+    -- fortunately this is a documented property of 'qualifyDeps'.+    rdeps <- requalify deps+    go deps rdeps+  where+    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()+    go = zipWithM_ go1++    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()+    go1 dep rdep = case (dep, rdep) of+      (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do+        vs <- get+        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs+            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs+        lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg'+        updateLinkGroup lg''+      (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do+        vs <- get+        case M.lookup fn (vsFlags vs) of+          Nothing    -> return () -- flag assignment not yet known+          Just True  -> go t t'+          Just False -> go f f'+      (Stanza sn t, ~(Stanza _ t')) -> do+        vs <- get+        case M.lookup sn (vsStanzas vs) of+          Nothing    -> return () -- stanza assignment not yet known+          Just True  -> go t t'+          Just False -> return () -- stanza not enabled; no new deps+    -- For extensions and language dependencies, there is nothing to do.+    -- No choice is involved, just checking, so there is nothing to link.+    -- The same goes for pkg-config constraints.+      (Simple (LDep _ (Ext  _))   _, _) -> return ()+      (Simple (LDep _ (Lang _))   _, _) -> return ()+      (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()++    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)+    requalify deps = do+      vs <- get+      return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)++pickFlag :: QFN -> Bool -> UpdateState ()+pickFlag qfn b = do+    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }+    verifyFlag qfn+    linkNewDeps (F qfn) b++pickStanza :: QSN -> Bool -> UpdateState ()+pickStanza qsn b = do+    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }+    verifyStanza qsn+    linkNewDeps (S qsn) b++-- | Link dependencies that we discover after making a flag or stanza choice.+--+-- When we make a flag choice for a package, then new dependencies for that+-- package might become available. If the package under consideration is in a+-- non-trivial link group, then these new dependencies have to be linked as+-- well. In linkNewDeps, we compute such new dependencies and make sure they are+-- linked.+linkNewDeps :: Var QPN -> Bool -> UpdateState ()+linkNewDeps var b = do+    vs <- get+    let qpn@(Q pp pn)           = varPN var+        qdeps                   = vsSaved vs ! qpn+        lg                      = vsLinks vs ! qpn+        newDeps                 = findNewDeps vs qdeps+        linkedTo                = S.delete pp (lgMembers lg)+    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps+  where+    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN+    findNewDeps vs = concatMap (findNewDeps' vs)++    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN+    findNewDeps' _  (Simple _ _)        = []+    findNewDeps' vs (Flagged qfn _ t f) =+      case (F qfn == var, M.lookup qfn (vsFlags vs)) of+        (True, _)    -> if b then t else f+        (_, Nothing) -> [] -- not yet known+        (_, Just b') -> findNewDeps vs (if b' then t else f)+    findNewDeps' vs (Stanza qsn t) =+      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of+        (True, _)    -> if b then t else []+        (_, Nothing) -> [] -- not yet known+        (_, Just b') -> findNewDeps vs (if b' then t else [])++updateLinkGroup :: LinkGroup -> UpdateState ()+updateLinkGroup lg = do+    verifyLinkGroup lg+    modify $ \vs -> vs {+        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))+                  `M.union` vsLinks vs+      }+  where+    aux pp = (Q pp (lgPackage lg), lg)++{-------------------------------------------------------------------------------+  Verification+-------------------------------------------------------------------------------}++verifyLinkGroup :: LinkGroup -> UpdateState ()+verifyLinkGroup lg =+    case lgInstance lg of+      -- No instance picked yet. Nothing to verify+      Nothing ->+        return ()++      -- We picked an instance. Verify flags and stanzas+      -- TODO: The enumeration of OptionalStanza names is very brittle;+      -- if a constructor is added to the datatype we won't notice it here+      Just i -> do+        vs <- get+        let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i+            flags   = M.keys finfo+            stanzas = [TestStanzas, BenchStanzas]+        forM_ flags $ \fn -> do+          let flag = FN (lgPackage lg) fn+          verifyFlag' flag lg+        forM_ stanzas $ \sn -> do+          let stanza = SN (lgPackage lg) sn+          verifyStanza' stanza lg++verifyFlag :: QFN -> UpdateState ()+verifyFlag (FN qpn@(Q _pp pn) fn) = do+    vs <- get+    -- We can only pick a flag after picking an instance; link group must exist+    verifyFlag' (FN pn fn) (vsLinks vs ! qpn)++verifyStanza :: QSN -> UpdateState ()+verifyStanza (SN qpn@(Q _pp pn) sn) = do+    vs <- get+    -- We can only pick a stanza after picking an instance; link group must exist+    verifyStanza' (SN pn sn) (vsLinks vs ! qpn)++-- | Verify that all packages in the link group agree on flag assignments+--+-- For the given flag and the link group, obtain all assignments for the flag+-- that have already been made for link group members, and check that they are+-- equal.+verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()+verifyFlag' (FN pn fn) lg = do+    vs <- get+    let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))+        vals  = map (`M.lookup` vsFlags vs) flags+    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags+      then return ()+      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg+                    , "flag \"" ++ unFlagName fn ++ "\" incompatible"+                    )++-- | Verify that all packages in the link group agree on stanza assignments+--+-- For the given stanza and the link group, obtain all assignments for the+-- stanza that have already been made for link group members, and check that+-- they are equal.+--+-- This function closely mirrors 'verifyFlag''.+verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()+verifyStanza' (SN pn sn) lg = do+    vs <- get+    let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))+        vals    = map (`M.lookup` vsStanzas vs) stanzas+    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas+      then return ()+      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg+                    , "stanza \"" ++ showStanza sn ++ "\" incompatible"+                    )++{-------------------------------------------------------------------------------+  Link groups+-------------------------------------------------------------------------------}++-- | Set of packages that must be linked together+--+-- A LinkGroup is between several qualified package names. In the validation+-- state, we maintain a map vsLinks from qualified package names to link groups.+-- There is an invariant that for all members of a link group, vsLinks must map+-- to the same link group. The function updateLinkGroup can be used to+-- re-establish this invariant after creating or expanding a LinkGroup.+data LinkGroup = LinkGroup {+      -- | The name of the package of this link group+      lgPackage :: PN++      -- | The canonical member of this link group (the one where we picked+      -- a concrete instance). Once we have picked a canonical member, all+      -- other packages must link to this one.+      --+      -- We may not know this yet (if we are constructing link groups+      -- for dependencies)+    , lgCanon :: Maybe (PI PackagePath)++      -- | The members of the link group+    , lgMembers :: Set PackagePath++      -- | The set of variables that should be added to the conflict set if+      -- something goes wrong with this link set (in addition to the members+      -- of the link group itself)+    , lgBlame :: ConflictSet+    }+    deriving (Show, Eq)++-- | Invariant for the set of link groups: every element in the link group+-- must be pointing to the /same/ link group+lgInvariant :: Map QPN LinkGroup -> Bool+lgInvariant links = all invGroup (M.elems links)+  where+    invGroup :: LinkGroup -> Bool+    invGroup lg = allEqual $ map (`M.lookup` links) members+      where+        members :: [QPN]+        members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg)++-- | Package version of this group+--+-- This is only known once we have picked a canonical element.+lgInstance :: LinkGroup -> Maybe I+lgInstance = fmap (\(PI _ i) -> i) . lgCanon++showLinkGroup :: LinkGroup -> String+showLinkGroup lg =+    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"+  where+    showMember :: PackagePath -> String+    showMember pp = case lgCanon lg of+                      Just (PI pp' _i) | pp == pp' -> "*"+                      _otherwise                   -> ""+                 ++ case lgInstance lg of+                      Nothing -> showQPN (qpn pp)+                      Just i  -> showPI (PI (qpn pp) i)++    qpn :: PackagePath -> QPN+    qpn pp = Q pp (lgPackage lg)++-- | Creates a link group that contains a single member.+lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup+lgSingleton (Q pp pn) canon = LinkGroup {+      lgPackage = pn+    , lgCanon   = canon+    , lgMembers = S.singleton pp+    , lgBlame   = CS.empty+    }++lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup+lgMerge blame lg lg' = do+    canon <- pick (lgCanon lg) (lgCanon lg')+    return LinkGroup {+        lgPackage = lgPackage lg+      , lgCanon   = canon+      , lgMembers = lgMembers lg `S.union` lgMembers lg'+      , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']+      }+  where+    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)+    pick Nothing  Nothing  = Right Nothing+    pick (Just x) Nothing  = Right $ Just x+    pick Nothing  (Just y) = Right $ Just y+    pick (Just x) (Just y) =+      if x == y then Right $ Just x+                else Left ( CS.unions [+                               blame+                             , lgConflictSet lg+                             , lgConflictSet lg'+                             ]+                          ,    "cannot merge " ++ showLinkGroup lg+                            ++ " and " ++ showLinkGroup lg'+                          )++lgConflictSet :: LinkGroup -> ConflictSet+lgConflictSet lg =+               CS.fromList (map aux (S.toList (lgMembers lg)))+    `CS.union` lgBlame lg+  where+    aux pp = P (Q pp (lgPackage lg))++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++allEqual :: Eq a => [a] -> Bool+allEqual []       = True+allEqual [_]      = True+allEqual (x:y:ys) = x == y && allEqual (y:ys)
+ cabal-install-solver/src/Distribution/Solver/Modular/Log.hs view
@@ -0,0 +1,31 @@+module Distribution.Solver.Modular.Log+    ( displayLogMessages+    , SolverFailure(..)+    ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude++import Distribution.Solver.Types.Progress++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.RetryLog++-- | Information about a dependency solver failure.+data SolverFailure =+    ExhaustiveSearch ConflictSet ConflictMap+  | BackjumpLimitReached++-- | Postprocesses a log file. This function discards all log messages and+-- avoids calling 'showMessages' if the log isn't needed (specified by+-- 'keepLog'), for efficiency.+displayLogMessages :: Bool+                   -> RetryLog Message SolverFailure a+                   -> RetryLog String SolverFailure a+displayLogMessages keepLog lg = fromProgress $+    if keepLog+    then showMessages progress+    else foldProgress (const id) Fail Done progress+  where+    progress = toProgress lg
+ cabal-install-solver/src/Distribution/Solver/Modular/Message.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE BangPatterns #-}++module Distribution.Solver.Modular.Message (+    Message(..),+    showMessages+  ) where++import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Maybe (catMaybes, mapMaybe)+import Prelude hiding (pi)++import Distribution.Pretty (prettyShow) -- from Cabal++import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+         ( FailReason(..), POption(..), ConflictingDep(..) )+import Distribution.Solver.Modular.Version+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.Progress+import Distribution.Types.LibraryName+import Distribution.Types.UnqualComponentName++data Message =+    Enter           -- ^ increase indentation level+  | Leave           -- ^ decrease indentation level+  | TryP QPN POption+  | TryF QFN Bool+  | TryS QSN Bool+  | Next (Goal QPN)+  | Skip (Set CS.Conflict)+  | Success+  | Failure ConflictSet FailReason++-- | Transforms the structured message type to actual messages (strings).+--+-- The log contains level numbers, which are useful for any trace that involves+-- backtracking, because only the level numbers will allow to keep track of+-- backjumps.+showMessages :: Progress Message a b -> Progress String a b+showMessages = go 0+  where+    -- 'go' increments the level for a recursive call when it encounters+    -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'.+    go :: Int -> Progress Message a b -> Progress String a b+    go !_ (Done x)                           = Done x+    go !_ (Fail x)                           = Fail x+    -- complex patterns+    go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        goPReject l qpn [i] c fr ms+    go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =+        goPSkip l qpn [i] conflicts ms+    go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)+    go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =+        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)+    go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =+        (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)+    go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =+        (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms+    -- standard display+    go !l (Step Enter                    ms) = go (l+1) ms+    go !l (Step Leave                    ms) = go (l-1) ms+    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)+    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)+    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)+    go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)+    go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log+    go !l (Step (Skip conflicts)         ms) =+        -- 'Skip' should always be handled by 'goPSkip' in the case above.+        (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)+    go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)+    go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms)++    showPackageGoal :: QPN -> QGoalReason -> String+    showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr++    showFailure :: ConflictSet -> FailReason -> String+    showFailure c fr = "fail" ++ showFR c fr++    -- special handler for many subsequent package rejections+    goPReject :: Int+              -> QPN+              -> [POption]+              -> ConflictSet+              -> FailReason+              -> Progress Message a b+              -> Progress String a b+    goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))+      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms+    goPReject l qpn is c fr ms =+        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)++    -- Handle many subsequent skipped package instances.+    goPSkip :: Int+            -> QPN+            -> [POption]+            -> Set CS.Conflict+            -> Progress Message a b+            -> Progress String a b+    goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))+      | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms+    goPSkip l qpn is conflicts ms =+      let msg = "skipping: "+                 ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))+                 ++ showConflicts conflicts+      in atLevel l msg (go l ms)++    -- write a message with the current level number+    atLevel :: Int -> String -> Progress String a b -> Progress String a b+    atLevel l x xs =+      let s = show l+      in  Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs++-- | Display the set of 'Conflicts' for a skipped package version.+showConflicts :: Set CS.Conflict -> String+showConflicts conflicts =+    " (has the same characteristics that caused the previous version to fail: "+     ++ conflictMsg ++ ")"+  where+    conflictMsg :: String+    conflictMsg =+      if S.member CS.OtherConflict conflicts+      then+        -- This case shouldn't happen, because an unknown conflict should not+        -- cause a version to be skipped.+        "unknown conflict"+      else let mergedConflicts =+                   [ showConflict qpn conflict+                   | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ]+           in if L.null mergedConflicts+              then+                  -- This case shouldn't happen unless backjumping is turned off.+                  "none"+              else L.intercalate "; " mergedConflicts++    -- Merge conflicts to simplify the log message.+    mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict+    mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList+      where+        mergeConflict :: MergedPackageConflict+                      -> MergedPackageConflict+                      -> MergedPackageConflict+        mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict {+              isGoalConflict =+                  isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2+            , versionConstraintConflict =+                  L.nub $ versionConstraintConflict mergedConflict1+                       ++ versionConstraintConflict mergedConflict2+            , versionConflict =+                  mergeVersionConflicts (versionConflict mergedConflict1)+                                        (versionConflict mergedConflict2)+            }+          where+            mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2)+            mergeVersionConflicts (Just vr1) Nothing    = Just vr1+            mergeVersionConflicts Nothing    (Just vr2) = Just vr2+            mergeVersionConflicts Nothing    Nothing    = Nothing++        toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict)+        toMergedConflict (CS.GoalConflict qpn) =+            Just (qpn, MergedPackageConflict True [] Nothing)+        toMergedConflict (CS.VersionConstraintConflict qpn v) =+            Just (qpn, MergedPackageConflict False [v] Nothing)+        toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =+            Just (qpn, MergedPackageConflict False [] (Just vr))+        toMergedConflict CS.OtherConflict = Nothing++    showConflict :: QPN -> MergedPackageConflict -> String+    showConflict qpn mergedConflict = L.intercalate "; " conflictStrings+      where+        conflictStrings = catMaybes [+            case () of+              () | isGoalConflict mergedConflict -> Just $+                     "depends on '" ++ showQPN qpn ++ "'" +++                         (if null (versionConstraintConflict mergedConflict)+                          then ""+                          else " but excludes "+                                ++ showVersions (versionConstraintConflict mergedConflict))+                 | not $ L.null (versionConstraintConflict mergedConflict) -> Just $+                     "excludes '" ++ showQPN qpn+                      ++ "' " ++ showVersions (versionConstraintConflict mergedConflict)+                 | otherwise -> Nothing+          , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'")+             <$> versionConflict mergedConflict+          ]++        showVersions []  = "no versions"+        showVersions [v] = "version " ++ showVer v+        showVersions vs  = "versions " ++ L.intercalate ", " (map showVer vs)++-- | All conflicts related to one package, used for simplifying the display of+-- a 'Set CS.Conflict'.+data MergedPackageConflict = MergedPackageConflict {+    isGoalConflict :: Bool+  , versionConstraintConflict :: [Ver]+  , versionConflict :: Maybe VR+  }++showQPNPOpt :: QPN -> POption -> String+showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =+  case linkedTo of+    Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption+    Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i)++showGR :: QGoalReason -> String+showGR UserGoal            = " (user goal)"+showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"++showFR :: ConflictSet -> FailReason -> String+showFR _ (UnsupportedExtension ext)       = " (conflict: requires " ++ prettyShow ext ++ ")"+showFR _ (UnsupportedLanguage lang)       = " (conflict: requires " ++ prettyShow lang ++ ")"+showFR _ (MissingPkgconfigPackage pn vr)  = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)"+showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"+showFR _ (ConflictingConstraints d1 d2)   = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"+showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")"+showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")"+showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")"+showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)"+showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"+showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)"+showFR _ CannotInstall                    = " (only already installed instances can be used)"+showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"+showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"+showFR _ Shadowed                         = " (shadowed by another installed package with same version)"+showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"+showFR _ UnknownPackage                   = " (unknown package)"+showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"+showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"+showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"+showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"+showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"+showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"+showFR _ MultipleInstances                = " (multiple instances)"+showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"+showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"+showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ prettyShow ver ++ ")"+-- The following are internal failures. They should not occur. In the+-- interest of not crashing unnecessarily, we still just print an error+-- message though.+showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"+showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"+showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"++showExposedComponent :: ExposedComponent -> String+showExposedComponent (ExposedLib LMainLibName)       = "library"+showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"+showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"++constraintSource :: ConstraintSource -> String+constraintSource src = "constraint from " ++ showConstraintSource src++showConflictingDep :: ConflictingDep -> String+showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =+  let DependencyReason qpn' _ _ = dr+      componentStr = case comp of+                       ExposedExe exe               -> " (exe " ++ unUnqualComponentName exe ++ ")"+                       ExposedLib LMainLibName      -> ""+                       ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")"+  in case ci of+       Fixed i        -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") +++                         showQPN qpn ++ componentStr ++ "==" ++ showI i+       Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn +++                         componentStr ++ showVR vr
+ cabal-install-solver/src/Distribution/Solver/Modular/PSQ.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.PSQ+    ( PSQ(..)  -- Unit test needs constructor access+    , casePSQ+    , cons+    , length+    , lookup+    , filter+    , filterIfAny+    , filterIfAnyByKeys+    , filterKeys+    , firstOnly+    , fromList+    , isZeroOrOne+    , keys+    , map+    , mapKeys+    , mapWithKey+    , maximumBy+    , minimumBy+    , null+    , prefer+    , preferByKeys+    , snoc+    , sortBy+    , sortByKeys+    , toList+    , union+    ) where++-- Priority search queues.+--+-- 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.++import Control.Arrow (first, second)++import qualified Data.Foldable as F+import Data.Function+import qualified Data.List as S+import Data.Ord (comparing)+import Data.Traversable+import Prelude hiding (foldr, length, lookup, filter, null, map)++newtype PSQ k v = PSQ [(k, v)]+  deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP++keys :: PSQ k v -> [k]+keys (PSQ xs) = fmap fst xs++lookup :: Eq k => k -> PSQ k v -> Maybe v+lookup k (PSQ xs) = S.lookup k xs++map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2+map f (PSQ xs) = PSQ (fmap (second f) xs)++mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v+mapKeys f (PSQ xs) = PSQ (fmap (first f) xs)++mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b+mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs)++fromList :: [(k, a)] -> PSQ k a+fromList = PSQ++cons :: k -> a -> PSQ k a -> PSQ k a+cons k x (PSQ xs) = PSQ ((k, x) : xs)++snoc :: PSQ k a -> k -> a -> PSQ k a+snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)])++casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r+casePSQ (PSQ xs) n c =+  case xs of+    []          -> n+    (k, v) : ys -> c k v (PSQ ys)++sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a+sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)++sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a+sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)++maximumBy :: (k -> Int) -> PSQ k a -> (k, a)+maximumBy sel (PSQ xs) =+  S.minimumBy (flip (comparing (sel . fst))) xs++minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a+minimumBy sel (PSQ xs) =+  PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]++-- | Sort the list so that values satisfying the predicate are first.+prefer :: (a -> Bool) -> PSQ k a -> PSQ k a+prefer p = sortBy $ flip (comparing p)++-- | Sort the list so that keys satisfying the predicate are first.+preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+preferByKeys p = sortByKeys $ flip (comparing p)++-- | Will partition the list according to the predicate. If+-- there is any element that satisfies the precidate, then only+-- the elements satisfying the predicate are returned.+-- Otherwise, the rest is returned.+--+filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a+filterIfAny p (PSQ xs) =+  let+    (pro, con) = S.partition (p . snd) xs+  in+    if S.null pro then PSQ con else PSQ pro++-- | Variant of 'filterIfAny' that takes a predicate on the keys+-- rather than on the values.+--+filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+filterIfAnyByKeys p (PSQ xs) =+  let+    (pro, con) = S.partition (p . fst) xs+  in+    if S.null pro then PSQ con else PSQ pro++filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a+filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)++filter :: (a -> Bool) -> PSQ k a -> PSQ k a+filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)++length :: PSQ k a -> Int+length (PSQ xs) = S.length xs++null :: PSQ k a -> Bool+null (PSQ xs) = S.null xs++isZeroOrOne :: PSQ k a -> Bool+isZeroOrOne (PSQ [])  = True+isZeroOrOne (PSQ [_]) = True+isZeroOrOne _         = False++firstOnly :: PSQ k a -> PSQ k a+firstOnly (PSQ [])      = PSQ []+firstOnly (PSQ (x : _)) = PSQ [x]++toList :: PSQ k a -> [(k, a)]+toList (PSQ xs) = xs++union :: PSQ k a -> PSQ k a -> PSQ k a+union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys)
+ cabal-install-solver/src/Distribution/Solver/Modular/Package.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Package+  ( I(..)+  , Loc(..)+  , PackageId+  , PackageIdentifier(..)+  , PackageName, mkPackageName, unPackageName+  , PkgconfigName, mkPkgconfigName, unPkgconfigName+  , PI(..)+  , PN+  , QPV+  , instI+  , makeIndependent+  , primaryPP+  , setupPP+  , showI+  , showPI+  , unPN+  ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude++import Distribution.Package -- from Cabal+import Distribution.Pretty (prettyShow)++import Distribution.Solver.Modular.Version+import Distribution.Solver.Types.PackagePath++-- | A package name.+type PN = PackageName++-- | Unpacking a package name.+unPN :: PN -> String+unPN = unPackageName++-- | Package version. A package name plus a version number.+type PV = PackageId++-- | Qualified package version.+type QPV = Qualified PV++-- | Package id. Currently just a black-box string.+type PId = UnitId++-- | Location. Info about whether a package is installed or not, and where+-- exactly it is located. For installed packages, uniquely identifies the+-- package instance via its 'PId'.+--+-- TODO: More information is needed about the repo.+data Loc = Inst PId | InRepo+  deriving (Eq, Ord, Show)++-- | Instance. A version number and a location.+data I = I Ver Loc+  deriving (Eq, Ord, Show)++-- | String representation of an instance.+showI :: I -> String+showI (I v InRepo)   = showVer v+showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid+  where+    extractPackageAbiHash xs =+      case first reverse $ break (=='-') $ reverse (prettyShow xs) of+        (ys, []) -> ys+        (ys, _)  -> '-' : ys++-- | Package instance. A package name and an instance.+data PI qpn = PI qpn I+  deriving (Eq, Ord, Show, Functor)++-- | String representation of a package instance.+showPI :: PI QPN -> String+showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i++instI :: I -> Bool+instI (I _ (Inst _)) = True+instI _              = False++-- | Is the package in the primary group of packages.  This is used to+-- determine (1) if we should try to establish stanza preferences+-- for this goal, and (2) whether or not a user specified @--constraint@+-- should apply to this dependency (grep 'primaryPP' to see the+-- use sites).  In particular this does not include packages pulled in+-- as setup deps.+--+primaryPP :: PackagePath -> Bool+primaryPP (PackagePath _ns q) = go q+  where+    go QualToplevel    = True+    go (QualBase  _)   = True+    go (QualSetup _)   = False+    go (QualExe _ _)   = False++-- | Is the package a dependency of a setup script.  This is used to+-- establish whether or not certain constraints should apply to this+-- dependency (grep 'setupPP' to see the use sites).+--+setupPP :: PackagePath -> Bool+setupPP (PackagePath _ns (QualSetup _)) = True+setupPP (PackagePath _ns _)         = False++-- | Qualify a target package with its own name so that its dependencies are not+-- required to be consistent with other targets.+makeIndependent :: PN -> QPN+makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn
+ cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Reordering or pruning the tree in order to prefer or make certain choices.+module Distribution.Solver.Modular.Preference+    ( avoidReinstalls+    , deferSetupExeChoices+    , deferWeakFlagChoices+    , enforceManualFlags+    , enforcePackageConstraints+    , enforceSingleInstanceRestriction+    , firstGoal+    , preferBaseGoalChoice+    , preferLinked+    , preferPackagePreferences+    , preferReallyEasyGoalChoices+    , requireInstalled+    , onlyConstrained+    , sortGoals+    , pruneAfterFirstSuccess+    ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude++import qualified Data.List as L+import qualified Data.Map as M+import Control.Monad.Trans.Reader (Reader, runReader, ask, local)++import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal++import Distribution.Solver.Types.Flag+import Distribution.Solver.Types.InstalledPreference+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.Variable++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import qualified Distribution.Solver.Modular.PSQ as P+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W++-- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a+-- list of weight-calculating functions in order to avoid sorting the package+-- choices multiple times. Each function takes the package name, sorted list of+-- children's versions, and package option. 'addWeights' prepends the new+-- weights to the existing weights, which gives precedence to preferences that+-- are applied later.+addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c+addWeights fs = trav go+  where+    go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c)+    go (PChoiceF qpn@(Q _ pn) rdm x cs) =+      let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs)+          weights k = [f pn sortedVersions k | f <- fs]++          elemsToWhnf :: [a] -> ()+          elemsToWhnf = foldr seq ()+      in  PChoiceF qpn rdm x+          -- Evaluate the children's versions before evaluating any of the+          -- subtrees, so that 'sortedVersions' doesn't hold onto all of the+          -- subtrees (referenced by cs) and cause a space leak.+          (elemsToWhnf sortedVersions `seq`+             W.mapWeightsWithKey (\k w -> weights k ++ w) cs)+    go x                            = x++addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c+addWeight f = addWeights [f]++version :: POption -> Ver+version (POption (I v _) _) = v++-- | Prefer to link packages whenever possible.+preferLinked :: Tree d c -> Tree d c+preferLinked = addWeight (const (const linked))+  where+    linked (POption _ Nothing)  = 1+    linked (POption _ (Just _)) = 0++-- Works by setting weights on choice nodes. Also applies stanza preferences.+preferPackagePreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c+preferPackagePreferences pcs =+    preferPackageStanzaPreferences pcs .+    addWeights [+          \pn _  opt -> preferred pn opt++        -- Note that we always rank installed before uninstalled, and later+        -- versions before earlier, but we can change the priority of the+        -- two orderings.+        , \pn vs opt -> case preference pn of+                          PreferInstalled -> installed opt+                          PreferLatest    -> latest vs opt+        , \pn vs opt -> case preference pn of+                          PreferInstalled -> latest vs opt+                          PreferLatest    -> installed opt+        ]+  where+    -- Prefer packages with higher version numbers over packages with+    -- lower version numbers.+    latest :: [Ver] -> POption -> Weight+    latest sortedVersions opt =+      let l = length sortedVersions+          index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions+      in  fromIntegral index / fromIntegral l++    preference :: PN -> InstalledPreference+    preference pn =+      let PackagePreferences _ ipref _ = pcs pn+      in  ipref++    -- | Prefer versions satisfying more preferred version ranges.+    preferred :: PN -> POption -> Weight+    preferred pn opt =+      let PackagePreferences vrs _ _ = pcs pn+      in fromIntegral . negate . L.length $+         L.filter (flip checkVR (version opt)) vrs++    -- Prefer installed packages over non-installed packages.+    installed :: POption -> Weight+    installed (POption (I _ (Inst _)) _) = 0+    installed _                          = 1++-- | Traversal that tries to establish package stanza enable\/disable+-- preferences. Works by reordering the branches of stanza choices.+preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c+preferPackageStanzaPreferences pcs = trav go+  where+    go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts)+      | primaryPP pp && enableStanzaPref pn s =+          -- move True case first to try enabling the stanza+          let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts+              weight k = if k then 0 else 1+          -- defer the choice by setting it to weak+          in  SChoiceF qsn rdm gr (WeakOrTrivial True) ts'+    go x = x++    enableStanzaPref :: PN -> OptionalStanza -> Bool+    enableStanzaPref pn s =+      let PackagePreferences _ _ spref = pcs pn+      in  s `elem` spref++-- | Helper function that tries to enforce a single package constraint on a+-- given instance for a P-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintP :: forall d c. QPN+                          -> ConflictSet+                          -> I+                          -> LabeledPackageConstraint+                          -> Tree d c+                          -> Tree d c+processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r =+    if constraintScopeMatches scope qpn+    then go i prop+    else r+  where+    go :: I -> PackageProperty -> Tree d c+    go (I v _) (PackagePropertyVersion vr)+        | checkVR vr v  = r+        | otherwise     = Fail c (GlobalConstraintVersion vr src)+    go _       PackagePropertyInstalled+        | instI i       = r+        | otherwise     = Fail c (GlobalConstraintInstalled src)+    go _       PackagePropertySource+        | not (instI i) = r+        | otherwise     = Fail c (GlobalConstraintSource src)+    go _       _        = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintF :: forall d c. QPN+                          -> Flag+                          -> ConflictSet+                          -> Bool+                          -> LabeledPackageConstraint+                          -> Tree d c+                          -> Tree d c+processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =+    if constraintScopeMatches scope qpn+    then go prop+    else r+  where+    go :: PackageProperty -> Tree d c+    go (PackagePropertyFlags fa) =+        case lookupFlagAssignment f fa of+          Nothing            -> r+          Just b | b == b'   -> r+                 | otherwise -> Fail c (GlobalConstraintFlag src)+    go _                             = r++-- | Helper function that tries to enforce a single package constraint on a+-- given flag setting for an F-node. Translates the constraint into a+-- tree-transformer that either leaves the subtree untouched, or replaces it+-- with an appropriate failure node.+processPackageConstraintS :: forall d c. QPN+                          -> OptionalStanza+                          -> ConflictSet+                          -> Bool+                          -> LabeledPackageConstraint+                          -> Tree d c+                          -> Tree d c+processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =+    if constraintScopeMatches scope qpn+    then go prop+    else r+  where+    go :: PackageProperty -> Tree d c+    go (PackagePropertyStanzas ss) =+        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)+                                 else r+    go _                               = r++-- | Traversal that tries to establish various kinds of user constraints. Works+-- by selectively disabling choices that have been ruled out by global user+-- constraints.+enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]+                          -> Tree d c+                          -> Tree d c+enforcePackageConstraints pcs = trav go+  where+    go (PChoiceF qpn@(Q _ pn) rdm gr                    ts) =+      let c = varToConflictSet (P qpn)+          -- compose the transformation functions for each of the relevant constraint+          g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc)+                                       id+                                       (M.findWithDefault [] pn pcs)+      in PChoiceF qpn rdm gr        (W.mapWithKey g ts)+    go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) =+      let c = varToConflictSet (F qfn)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc)+                           id+                           (M.findWithDefault [] pn pcs)+      in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts)+    go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr   ts) =+      let c = varToConflictSet (S qsn)+          -- compose the transformation functions for each of the relevant constraint+          g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc)+                           id+                           (M.findWithDefault [] pn pcs)+      in SChoiceF qsn rdm gr tr     (W.mapWithKey g ts)+    go x = x++-- | Transformation that tries to enforce the rule that manual flags can only be+-- set by the user.+--+-- If there are no constraints on a manual flag, this function prunes all but+-- the default value. If there are constraints, then the flag is allowed to have+-- the values specified by the constraints. Note that the type used for flag+-- values doesn't need to be Bool.+--+-- This function makes an exception for the case where there are multiple goals+-- for a single package (with different qualifiers), and flag constraints for+-- manual flag x only apply to some of those goals. In that case, we allow the+-- unconstrained goals to use the default value for x OR any of the values in+-- the constraints on x (even though the constraints don't apply), in order to+-- allow the unconstrained goals to be linked to the constrained goals. See+-- https://github.com/haskell/cabal/issues/4299. Removing the single instance+-- restriction (SIR) would also fix #4299, so we may want to remove this+-- exception and only let the user toggle manual flags if we remove the SIR.+--+-- This function does not enforce any of the constraints, since that is done by+-- 'enforcePackageConstraints'.+enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c+enforceManualFlags pcs = trav go+  where+    go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =+        FChoiceF qfn rdm gr tr Manual d $+          let -- A list of all values specified by constraints on 'fn'.+              -- We ignore the constraint scope in order to handle issue #4299.+              flagConstraintValues :: [Bool]+              flagConstraintValues =+                  [ flagVal+                  | let lpcs = M.findWithDefault [] pn pcs+                  , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs+                  , (fn', flagVal) <- unFlagAssignment fa+                  , fn' == fn ]++              -- Prune flag values that are not the default and do not match any+              -- of the constraints.+              restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c+              restrictToggling flagDefault constraintVals flagVal r =+                  if flagVal `elem` constraintVals || flagVal == flagDefault+                  then r+                  else Fail (varToConflictSet (F qfn)) ManualFlag++      in W.mapWithKey (restrictToggling d flagConstraintValues) ts+    go x                                                            = x++-- | Require installed packages.+requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c+requireInstalled p = trav go+  where+    go (PChoiceF v@(Q _ pn) rdm gr cs)+      | p pn      = PChoiceF v rdm gr (W.mapWithKey installed cs)+      | otherwise = PChoiceF v rdm gr                         cs+      where+        installed (POption (I _ (Inst _)) _) x = x+        installed _ _ = Fail (varToConflictSet (P v)) CannotInstall+    go x          = x++-- | Avoid reinstalls.+--+-- This is a tricky strategy. If a package version is installed already and the+-- same version is available from a repo, the repo version will never be chosen.+-- This would result in a reinstall (either destructively, or potentially,+-- shadowing). The old instance won't be visible or even present anymore, but+-- other packages might have depended on it.+--+-- TODO: It would be better to actually check the reverse dependencies of installed+-- packages. If they're not depended on, then reinstalling should be fine. Even if+-- they are, perhaps this should just result in trying to reinstall those other+-- packages as well. However, doing this all neatly in one pass would require to+-- change the builder, or at least to change the goal set after building.+avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c+avoidReinstalls p = trav go+  where+    go (PChoiceF qpn@(Q _ pn) rdm gr cs)+      | p pn      = PChoiceF qpn rdm gr disableReinstalls+      | otherwise = PChoiceF qpn rdm gr cs+      where+        disableReinstalls =+          let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ]+          in  W.mapWithKey (notReinstall installed) cs++        notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs =+          Fail (varToConflictSet (P qpn)) CannotReinstall+        notReinstall _ _ x =+          x+    go x          = x++-- | Require all packages to be mentioned in a constraint or as a goal.+onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason+onlyConstrained p = trav go+  where+    go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn)+      = FailF+        (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr)+        NotExplicit+    go x+      = x++-- | Sort all goals using the provided function.+sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c+sortGoals variableOrder = trav go+  where+    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs)+    go x                    = x++    goalOrder :: Goal QPN -> Goal QPN -> Ordering+    goalOrder = variableOrder `on` (varToVariable . goalToVar)++    varToVariable :: Var QPN -> Variable QPN+    varToVariable (P qpn)                    = PackageVar qpn+    varToVariable (F (FN qpn fn))     = FlagVar qpn fn+    varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza++-- | Reduce the branching degree of the search tree by removing all choices+-- after the first successful choice at each level. The returned tree is the+-- minimal subtree containing the path to the first backjump.+pruneAfterFirstSuccess :: Tree d c -> Tree d c+pruneAfterFirstSuccess = trav go+  where+    go (PChoiceF qpn rdm gr       ts) = PChoiceF qpn rdm gr       (W.takeUntil active ts)+    go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts)+    go (SChoiceF qsn rdm gr w     ts) = SChoiceF qsn rdm gr w     (W.takeUntil active ts)+    go x                              = x++-- | Always choose the first goal in the list next, abandoning all+-- other choices.+--+-- This is unnecessary for the default search strategy, because+-- it descends only into the first goal choice anyway,+-- but may still make sense to just reduce the tree size a bit.+firstGoal :: Tree d c -> Tree d c+firstGoal = trav go+  where+    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs)+    go x                    = x+    -- Note that we keep empty choice nodes, because they mean success.++-- | Transformation that tries to make a decision on base as early as+-- possible by pruning all other goals when base is available. In nearly+-- all cases, there's a single choice for the base package. Also, fixing+-- base early should lead to better error messages.+preferBaseGoalChoice :: Tree d c -> Tree d c+preferBaseGoalChoice = trav go+  where+    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs)+    go x                    = x++    isBase :: Goal QPN -> Bool+    isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base"+    isBase _                       = False++-- | Deal with setup and build-tool-depends dependencies after regular dependencies,+-- so we will link setup/exe dependencies against package dependencies when possible+deferSetupExeChoices :: Tree d c -> Tree d c+deferSetupExeChoices = trav go+  where+    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetupOrExe xs)+    go x                    = x++    noSetupOrExe :: Goal QPN -> Bool+    noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False+    noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False+    noSetupOrExe _                                                  = True++-- | 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 d c -> Tree d c+deferWeakFlagChoices = trav go+  where+    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs))+    go x                    = x++    noWeakStanza :: Tree d c -> Bool+    noWeakStanza (SChoice _ _ _ (WeakOrTrivial True)   _) = False+    noWeakStanza _                                        = True++    noWeakFlag :: Tree d c -> Bool+    noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False+    noWeakFlag _                                          = True++-- | Transformation that prefers goals with lower branching degrees.+--+-- When a goal choice node has at least one goal with zero or one children, this+-- function prunes all other goals. This transformation can help the solver find+-- a solution in fewer steps by allowing it to backtrack sooner when it is+-- exploring a subtree with no solutions. However, each step is more expensive.+preferReallyEasyGoalChoices :: Tree d c -> Tree d c+preferReallyEasyGoalChoices = trav go+  where+    go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs)+    go x                    = x++-- | Monad used internally in enforceSingleInstanceRestriction+--+-- For each package instance we record the goal for which we picked a concrete+-- instance. The SIR means that for any package instance there can only be one.+type EnforceSIR = Reader (Map (PI PN) QPN)++-- | Enforce ghc's single instance restriction+--+-- From the solver's perspective, this means that for any package instance+-- (that is, package name + package version) there can be at most one qualified+-- goal resolving to that instance (there may be other goals _linking_ to that+-- instance however).+enforceSingleInstanceRestriction :: Tree d c -> Tree d c+enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go+  where+    go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c)++    -- We just verify package choices.+    go (PChoiceF qpn rdm gr cs) =+      PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs)+    go _otherwise =+      innM _otherwise++    -- The check proper+    goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c)+    goP qpn@(Q _ pn) (POption i linkedTo) r = do+      let inst = PI pn i+      env <- ask+      case (linkedTo, M.lookup inst env) of+        (Just _, _) ->+          -- For linked nodes we don't check anything+          r+        (Nothing, Nothing) ->+          -- Not linked, not already used+          local (M.insert inst qpn) r+        (Nothing, Just qpn') -> do+          -- Not linked, already used. This is an error+          return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances
+ cabal-install-solver/src/Distribution/Solver/Modular/RetryLog.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE Rank2Types #-}+module Distribution.Solver.Modular.RetryLog+    ( RetryLog+    , toProgress+    , fromProgress+    , mapFailure+    , retry+    , failWith+    , succeedWith+    , continueWith+    , tryWith+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Solver.Modular.Message+import Distribution.Solver.Types.Progress++-- | 'Progress' as a difference list that allows efficient appends at failures.+newtype RetryLog step fail done = RetryLog {+    unRetryLog :: forall fail2 . (fail -> Progress step fail2 done)+               -> Progress step fail2 done+  }++-- | /O(1)/. Convert a 'RetryLog' to a 'Progress'.+toProgress :: RetryLog step fail done -> Progress step fail done+toProgress (RetryLog f) = f Fail++-- | /O(N)/. Convert a 'Progress' to a 'RetryLog'.+fromProgress :: Progress step fail done -> RetryLog step fail done+fromProgress l = RetryLog $ \f -> go f l+  where+    go :: (fail1 -> Progress step fail2 done)+       -> Progress step fail1 done+       -> Progress step fail2 done+    go _ (Done d) = Done d+    go f (Fail failure) = f failure+    go f (Step m ms) = Step m (go f ms)++-- | /O(1)/. Apply a function to the failure value in a log.+mapFailure :: (fail1 -> fail2)+           -> RetryLog step fail1 done+           -> RetryLog step fail2 done+mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure)++-- | /O(1)/. If the first log leads to failure, continue with the second.+retry :: RetryLog step fail1 done+      -> (fail1 -> RetryLog step fail2 done)+      -> RetryLog step fail2 done+retry (RetryLog f) g =+    RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog++-- | /O(1)/. Create a log with one message before a failure.+failWith :: step -> fail -> RetryLog step fail done+failWith m failure = RetryLog $ \f -> Step m (f failure)++-- | /O(1)/. Create a log with one message before a success.+succeedWith :: step -> done -> RetryLog step fail done+succeedWith m d = RetryLog $ const $ Step m (Done d)++-- | /O(1)/. Prepend a message to a log.+continueWith :: step+             -> RetryLog step fail done+             -> RetryLog step fail done+continueWith m (RetryLog f) = RetryLog $ Step m . f++-- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert+-- 'Leave' before the failure if the log fails.+tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done+tryWith m f =+  RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave))
+ cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP #-}+#ifdef DEBUG_TRACETREE+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+#endif+module Distribution.Solver.Modular.Solver+    ( SolverConfig(..)+    , solve+    , PruneAfterFirstSuccess(..)+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import qualified Data.Map as M+import qualified Data.List as L+import qualified Data.Set as S+import Distribution.Verbosity++import Distribution.Compiler (CompilerInfo)++import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.Variable++import Distribution.Solver.Modular.Assignment+import Distribution.Solver.Modular.Builder+import Distribution.Solver.Modular.Cycles+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Explore+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Log+import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.Package+import qualified Distribution.Solver.Modular.Preference as P+import Distribution.Solver.Modular.Validate+import Distribution.Solver.Modular.Linking+import Distribution.Solver.Modular.PSQ (PSQ)+import Distribution.Solver.Modular.RetryLog+import Distribution.Solver.Modular.Tree+import qualified Distribution.Solver.Modular.PSQ as PSQ++import Distribution.Simple.Setup (BooleanFlag(..))++#ifdef DEBUG_TRACETREE+import qualified Distribution.Solver.Modular.ConflictSet as CS+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import qualified Distribution.Deprecated.Text as T++import Debug.Trace.Tree (gtraceJson)+import Debug.Trace.Tree.Simple+import Debug.Trace.Tree.Generic+import Debug.Trace.Tree.Assoc (Assoc(..))+#endif++-- | Various options for the modular solver.+data SolverConfig = SolverConfig {+  reorderGoals           :: ReorderGoals,+  countConflicts         :: CountConflicts,+  fineGrainedConflicts   :: FineGrainedConflicts,+  minimizeConflictSet    :: MinimizeConflictSet,+  independentGoals       :: IndependentGoals,+  avoidReinstalls        :: AvoidReinstalls,+  shadowPkgs             :: ShadowPkgs,+  strongFlags            :: StrongFlags,+  allowBootLibInstalls   :: AllowBootLibInstalls,+  onlyConstrained        :: OnlyConstrained,+  maxBackjumps           :: Maybe Int,+  enableBackjumping      :: EnableBackjumping,+  solveExecutables       :: SolveExecutables,+  goalOrder              :: Maybe (Variable QPN -> Variable QPN -> Ordering),+  solverVerbosity        :: Verbosity,+  pruneAfterFirstSuccess :: PruneAfterFirstSuccess+}++-- | Whether to remove all choices after the first successful choice at each+-- level in the search tree.+newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool++-- | Run all solver phases.+--+-- In principle, we have a valid tree after 'validationPhase', which+-- means that every 'Done' node should correspond to valid solution.+--+-- There is one exception, though, and that is cycle detection, which+-- has been added relatively recently. Cycles are only removed directly+-- before exploration.+--+solve :: SolverConfig                         -- ^ solver parameters+      -> CompilerInfo+      -> Index                                -- ^ all available packages as an index+      -> PkgConfigDb                          -- ^ available pkg-config pkgs+      -> (PN -> PackagePreferences)           -- ^ preferences+      -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints+      -> S.Set PN                             -- ^ global goals+      -> RetryLog Message SolverFailure (Assignment, RevDepMap)+solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =+  explorePhase     $+  detectCycles     $+  heuristicsPhase  $+  preferencesPhase $+  validationPhase  $+  prunePhase       $+  buildPhase+  where+    explorePhase     = backjumpAndExplore (maxBackjumps sc)+                                          (enableBackjumping sc)+                                          (fineGrainedConflicts sc)+                                          (countConflicts sc)+                                          idx+    detectCycles     = traceTree "cycles.json" id . detectCyclesPhase+    heuristicsPhase  =+      let heuristicsTree = traceTree "heuristics.json" id+          sortGoals = case goalOrder sc of+                        Nothing -> goalChoiceHeuristics .+                                   heuristicsTree .+                                   P.deferSetupExeChoices .+                                   P.deferWeakFlagChoices .+                                   P.preferBaseGoalChoice+                        Just order -> P.firstGoal .+                                   heuristicsTree .+                                   P.sortGoals order+          PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc+      in sortGoals .+         (if prune then P.pruneAfterFirstSuccess else id)+    preferencesPhase = P.preferLinked .+                       P.preferPackagePreferences userPrefs+    validationPhase  = traceTree "validated.json" id .+                       P.enforcePackageConstraints userConstraints .+                       P.enforceManualFlags userConstraints .+                       P.enforceSingleInstanceRestriction .+                       validateLinking idx .+                       validateTree cinfo idx pkgConfigDB+    prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .+                       (if asBool (allowBootLibInstalls sc)+                        then id+                        else P.requireInstalled (`elem` nonInstallable)) .+                       (case onlyConstrained sc of+                          OnlyConstrainedAll ->+                            P.onlyConstrained pkgIsExplicit+                          OnlyConstrainedNone ->+                            id)+    buildPhase       = traceTree "build.json" id+                     $ buildTree idx (independentGoals sc) (S.toList userGoals)++    allExplicit = M.keysSet userConstraints `S.union` userGoals++    pkgIsExplicit :: PN -> Bool+    pkgIsExplicit pn = S.member pn allExplicit++    -- packages that can never be installed or upgraded+    -- If you change this enumeration, make sure to update the list in+    -- "Distribution.Client.Dependency" as well+    nonInstallable :: [PackageName]+    nonInstallable =+        L.map mkPackageName+             [ "base"+             , "ghc-prim"+             , "integer-gmp"+             , "integer-simple"+             , "template-haskell"+             ]++    -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which+    -- prefers (keeps) goals only if the have 0 or 1 enabled choice.+    --+    -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes+    -- to just a single option. This was a way to work around a space leak that was+    -- unnecessary and is now fixed, so we no longer do it.+    --+    -- If --count-conflicts is active, it will then choose among the remaining goals+    -- the one that has been responsible for the most conflicts so far.+    --+    -- Otherwise, we simply choose the first remaining goal.+    --+    goalChoiceHeuristics+      | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices+      | otherwise                = id {- P.firstGoal -}++-- | Dump solver tree to a file (in debugging mode)+--+-- This only does something if the @debug-tracetree@ configure argument was+-- given; otherwise this is just the identity function.+traceTree ::+#ifdef DEBUG_TRACETREE+  GSimpleTree a =>+#endif+     FilePath  -- ^ Output file+  -> (a -> a)  -- ^ Function to summarize the tree before dumping+  -> a -> a+#ifdef DEBUG_TRACETREE+traceTree = gtraceJson+#else+traceTree _ _ = id+#endif++#ifdef DEBUG_TRACETREE+instance GSimpleTree (Tree d c) where+  fromGeneric = go+    where+      go :: Tree d c -> SimpleTree+      go (PChoice qpn _ _       psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList  psq+      go (FChoice _   _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq+      go (SChoice _   _ _ _     psq) = Node "S" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq+      go (GoalChoice  _         psq) = Node "G" $ Assoc $ L.map (uncurry goG)       $ PSQ.toList psq+      go (Done _rdm _s)              = Node "D" $ Assoc []+      go (Fail cs _reason)           = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]++      psqToList :: W.WeightedPSQ w k v -> [(k, v)]+      psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList++      -- Show package choice+      goP :: QPN -> POption -> Tree d c -> (String, SimpleTree)+      goP _        (POption (I ver _loc) Nothing)  subtree = (T.display ver, go subtree)+      goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)++      -- Show flag or stanza choice+      goFS :: Bool -> Tree d c -> (String, SimpleTree)+      goFS val subtree = (show val, go subtree)++      -- Show goal choice+      goG :: Goal QPN -> Tree d c -> (String, SimpleTree)+      goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)++      -- Variation on 'showGR' that produces shorter strings+      -- (Actually, QGoalReason records more info than necessary: we only need+      -- to know the variable that introduced the goal, not the value assigned+      -- to that variable)+      shortGR :: QGoalReason -> String+      shortGR UserGoal            = "user"+      shortGR (DependencyGoal dr) = showDependencyReason dr++      -- Show conflict set+      goCS :: ConflictSet -> String+      goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"+#endif++-- | Replace all goal reasons with a dummy goal reason in the tree+--+-- This is useful for debugging (when experimenting with the impact of GRs)+_removeGR :: Tree d c -> Tree d QGoalReason+_removeGR = trav go+  where+   go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)+   go (PChoiceF qpn rdm _       psq) = PChoiceF qpn rdm dummy       psq+   go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq+   go (SChoiceF qsn rdm _ a     psq) = SChoiceF qsn rdm dummy a     psq+   go (GoalChoiceF  rdm         psq) = GoalChoiceF  rdm             (goG psq)+   go (DoneF rdm s)                  = DoneF rdm s+   go (FailF cs reason)              = FailF cs reason++   goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)+   goG = PSQ.fromList+       . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))+       . PSQ.toList++   dummy :: QGoalReason+   dummy =+       DependencyGoal $+       DependencyReason+           (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$"))+           M.empty S.empty
+ cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Distribution.Solver.Modular.Tree+    ( POption(..)+    , Tree(..)+    , TreeF(..)+    , Weight+    , FailReason(..)+    , ConflictingDep(..)+    , ana+    , cata+    , inn+    , innM+    , para+    , trav+    , zeroOrOneChoices+    , active+    ) where++import Control.Monad hiding (mapM, sequence)+import Data.Foldable+import Data.Traversable+import Prelude hiding (foldr, mapM, sequence)++import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.PSQ (PSQ)+import Distribution.Solver.Modular.Version+import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)+import qualified Distribution.Solver.Modular.WeightedPSQ as W+import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.Flag+import Distribution.Solver.Types.PackagePath+import Distribution.Types.PkgconfigVersionRange+import Distribution.Types.UnitId (UnitId)+import Language.Haskell.Extension (Extension, Language)++type Weight = Double++-- | Type of the search tree. Inlining the choice nodes for now. Weights on+-- package, flag, and stanza choices control the traversal order.+--+-- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes+-- (type 'c'). For example, during the final traversal, choice nodes contain the+-- variables that introduced the choices, and 'Done' nodes contain the+-- assignments for all variables.+--+-- TODO: The weight type should be changed from [Double] to Double to avoid+-- giving too much weight to preferences that are applied later.+data Tree d c =+    -- | Choose a version for a package (or choose to link)+    PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c))++    -- | Choose a value for a flag+    --+    -- The Bool is the default value.+  | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c))++    -- | Choose whether or not to enable a stanza+  | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c))++    -- | Choose which choice to make next+    --+    -- Invariants:+    --+    -- * PSQ should never be empty+    -- * For each choice we additionally record the 'QGoalReason' why we are+    --   introducing that goal into tree. Note that most of the time we are+    --   working with @Tree QGoalReason@; in that case, we must have the+    --   invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice'+    --   or 'SChoice' directly below a 'GoalChoice' node must equal the reason+    --   recorded on that 'GoalChoice' node.+  | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c))++    -- | We're done -- we found a solution!+  | Done RevDepMap d++    -- | We failed to find a solution in this path through the tree+  | Fail ConflictSet FailReason++-- | A package option is a package instance with an optional linking annotation+--+-- The modular solver has a number of package goals to solve for, and can only+-- pick a single package version for a single goal. In order to allow to+-- install multiple versions of the same package as part of a single solution+-- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both+-- be qualified goals for @P@, allowing to pick a difference version of package+-- @P@ for @0.P@ and @1.P@.+--+-- Linking is an essential part of this story. In addition to picking a specific+-- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or+-- vice versa). It means that @1.P@ and @0.P@ really must be the very same package+-- (and hence must have the same build time configuration, and their+-- dependencies must also be the exact same).+--+-- See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.+data POption = POption I (Maybe PackagePath)+  deriving (Eq, Show)++data FailReason = UnsupportedExtension Extension+                | UnsupportedLanguage Language+                | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange+                | NewPackageDoesNotMatchExistingConstraint ConflictingDep+                | ConflictingConstraints ConflictingDep ConflictingDep+                | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN)+                | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN)+                | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN)+                | PackageRequiresMissingComponent QPN ExposedComponent+                | PackageRequiresPrivateComponent QPN ExposedComponent+                | PackageRequiresUnbuildableComponent QPN ExposedComponent+                | CannotInstall+                | CannotReinstall+                | NotExplicit+                | Shadowed+                | Broken UnitId+                | UnknownPackage+                | GlobalConstraintVersion VR ConstraintSource+                | GlobalConstraintInstalled ConstraintSource+                | GlobalConstraintSource ConstraintSource+                | GlobalConstraintFlag ConstraintSource+                | ManualFlag+                | MalformedFlagChoice QFN+                | MalformedStanzaChoice QSN+                | EmptyGoalChoice+                | Backjump+                | MultipleInstances+                | DependenciesNotLinked String+                | CyclicDependencies+                | UnsupportedSpecVer Ver+  deriving (Eq, Show)++-- | Information about a dependency involved in a conflict, for error messages.+data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI+  deriving (Eq, Show)++-- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c'+-- have the same meaning as in 'Tree'.+data TreeF d c a =+    PChoiceF    QPN RevDepMap c                             (WeightedPSQ [Weight] POption a)+  | FChoiceF    QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool    a)+  | SChoiceF    QSN RevDepMap c WeakOrTrivial               (WeightedPSQ [Weight] Bool    a)+  | GoalChoiceF     RevDepMap                               (PSQ (Goal QPN) a)+  | DoneF           RevDepMap d+  | FailF       ConflictSet FailReason+  deriving (Functor, Foldable, Traversable)++out :: Tree d c -> TreeF d c (Tree d c)+out (PChoice    p s i       ts) = PChoiceF    p s i       ts+out (FChoice    p s i b m d ts) = FChoiceF    p s i b m d ts+out (SChoice    p s i b     ts) = SChoiceF    p s i b     ts+out (GoalChoice   s         ts) = GoalChoiceF   s         ts+out (Done       x s           ) = DoneF       x s+out (Fail       c x           ) = FailF       c x++inn :: TreeF d c (Tree d c) -> Tree d c+inn (PChoiceF    p s i       ts) = PChoice    p s i       ts+inn (FChoiceF    p s i b m d ts) = FChoice    p s i b m d ts+inn (SChoiceF    p s i b     ts) = SChoice    p s i b     ts+inn (GoalChoiceF   s         ts) = GoalChoice   s         ts+inn (DoneF       x s           ) = Done       x s+inn (FailF       c x           ) = Fail       c x++innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c)+innM (PChoiceF    p s i       ts) = liftM (PChoice    p s i      ) (sequence ts)+innM (FChoiceF    p s i b m d ts) = liftM (FChoice    p s i b m d) (sequence ts)+innM (SChoiceF    p s i b     ts) = liftM (SChoice    p s i b    ) (sequence ts)+innM (GoalChoiceF   s         ts) = liftM (GoalChoice   s        ) (sequence ts)+innM (DoneF       x s           ) = return $ Done     x s+innM (FailF       c x           ) = return $ Fail     c x++-- | Determines whether a tree is active, i.e., isn't a failure node.+active :: Tree d c -> Bool+active (Fail _ _) = False+active _          = True++-- | Approximates the number of active choices that are available in a node.+-- Note that we count goal choices as having one choice, always.+zeroOrOneChoices :: Tree d c -> Bool+zeroOrOneChoices (PChoice    _ _ _       ts) = W.isZeroOrOne (W.filter active ts)+zeroOrOneChoices (FChoice    _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts)+zeroOrOneChoices (SChoice    _ _ _ _     ts) = W.isZeroOrOne (W.filter active ts)+zeroOrOneChoices (GoalChoice _           _ ) = True+zeroOrOneChoices (Done       _ _           ) = True+zeroOrOneChoices (Fail       _ _           ) = True++-- | Catamorphism on trees.+cata :: (TreeF d c a -> a) -> Tree d c -> a+cata phi x = (phi . fmap (cata phi) . out) x++trav :: (TreeF d c (Tree d a) -> TreeF d a (Tree d a)) -> Tree d c -> Tree d a+trav psi x = cata (inn . psi) x++-- | Paramorphism on trees.+para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a+para phi = phi . fmap (\ x -> (para phi x, x)) . out++-- | Anamorphism on trees.+ana :: (a -> TreeF d c a) -> a -> Tree d c+ana psi = inn . fmap (ana psi) . psi
+ cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+#ifdef DEBUG_CONFLICT_SETS+{-# LANGUAGE ImplicitParams #-}+#endif+module Distribution.Solver.Modular.Validate (validateTree) where++-- Validation of the tree.+--+-- The task here is to make sure all constraints hold. After validation, any+-- assignment returned by exploration of the tree should be a complete valid+-- assignment, i.e., actually constitute a solution.++import Control.Applicative+import Control.Monad.Reader hiding (sequence)+import Data.Either (lefts)+import Data.Function (on)+import Data.Traversable+import Prelude hiding (sequence)++import qualified Data.List as L+import qualified Data.Set as S++import Language.Haskell.Extension (Extension, Language)++import Data.Map.Strict as M+import Distribution.Compiler (CompilerInfo(..))++import Distribution.Solver.Modular.Assignment+import qualified Distribution.Solver.Modular.ConflictSet as CS+import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Index+import Distribution.Solver.Modular.Package+import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version+import qualified Distribution.Solver.Modular.WeightedPSQ as W++import Distribution.Solver.Types.PackagePath+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)+import Distribution.Types.LibraryName+import Distribution.Types.PkgconfigVersionRange++#ifdef DEBUG_CONFLICT_SETS+import GHC.Stack (CallStack)+#endif++-- In practice, most constraints are implication constraints (IF we have made+-- a number of choices, THEN we also have to ensure that). We call constraints+-- that for which the preconditions are fulfilled ACTIVE. We maintain a set+-- of currently active constraints that we pass down the node.+--+-- We aim at detecting inconsistent states as early as possible.+--+-- Whenever we make a choice, there are two things that need to happen:+--+--   (1) We must check that the choice is consistent with the currently+--       active constraints.+--+--   (2) The choice increases the set of active constraints. For the new+--       active constraints, we must check that they are consistent with+--       the current state.+--+-- We can actually merge (1) and (2) by saying the current choice is+-- a new active constraint, fixing the choice.+--+-- If a test fails, we have detected an inconsistent state. We can+-- disable the current subtree and do not have to traverse it any further.+--+-- We need a good way to represent the current state, i.e., the current+-- set of active constraints. Since the main situation where we have to+-- search in it is (1), it seems best to store the state by package: for+-- every package, we store which versions are still allowed. If for any+-- package, we have inconsistent active constraints, we can also stop.+-- This is a particular way to read task (2):+--+--   (2, weak) We only check if the new constraints are consistent with+--       the choices we've already made, and add them to the active set.+--+--   (2, strong) We check if the new constraints are consistent with the+--       choices we've already made, and the constraints we already have.+--+-- It currently seems as if we're implementing the weak variant. However,+-- when used together with 'preferEasyGoalChoices', we will find an+-- inconsistent state in the very next step.+--+-- What do we do about flags?+--+-- Like for packages, we store the flag choices we have already made.+-- Now, regarding (1), we only have to test whether we've decided the+-- current flag before. Regarding (2), the interesting bit is in discovering+-- the new active constraints. To this end, we look up the constraints for+-- the package the flag belongs to, and traverse its flagged dependencies.+-- Wherever we find the flag in question, we start recording dependencies+-- underneath as new active dependencies. If we encounter other flags, we+-- check if we've chosen them already and either proceed or stop.++-- | The state needed during validation.+data ValidateState = VS {+  supportedExt        :: Extension -> Bool,+  supportedLang       :: Language  -> Bool,+  presentPkgs         :: PkgconfigName -> PkgconfigVersionRange  -> Bool,+  index               :: Index,++  -- Saved, scoped, dependencies. Every time 'validate' makes a package choice,+  -- it qualifies the package's dependencies and saves them in this map. Then+  -- the qualified dependencies are available for subsequent flag and stanza+  -- choices for the same package.+  saved               :: Map QPN (FlaggedDeps QPN),++  pa                  :: PreAssignment,++  -- Map from package name to the components that are provided by the chosen+  -- instance of that package, and whether those components are visible and+  -- buildable.+  availableComponents :: Map QPN (Map ExposedComponent ComponentInfo),++  -- Map from package name to the components that are required from that+  -- package.+  requiredComponents  :: Map QPN ComponentDependencyReasons,++  qualifyOptions      :: QualifyOptions+}++newtype Validate a = Validate (Reader ValidateState a)+  deriving (Functor, Applicative, Monad, MonadReader ValidateState)++runValidate :: Validate a -> ValidateState -> a+runValidate (Validate r) = runReader r++-- | A preassignment comprises knowledge about variables, but not+-- necessarily fixed values.+data PreAssignment = PA PPreAssignment FAssignment SAssignment++-- | A (partial) package preassignment. Qualified package names+-- are associated with MergedPkgDeps.+type PPreAssignment = Map QPN MergedPkgDep++-- | A dependency on a component, including its DependencyReason.+data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI++-- | Map from component name to one of the reasons that the component is+-- required.+type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN)++-- | MergedPkgDep records constraints about the instances that can still be+-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a+-- list of version ranges paired with the goals / variables that introduced+-- them. It also records whether a package is a build-tool dependency, for each+-- reason that it was introduced.+--+-- It is important to store the component name with the version constraint, for+-- error messages, because whether something is a build-tool dependency affects+-- its qualifier, which affects which constraint is applied.+data MergedPkgDep =+    MergedDepFixed ExposedComponent (DependencyReason QPN) I+  | MergedDepConstrained [VROrigin]++-- | Version ranges paired with origins.+type VROrigin = (VR, ExposedComponent, DependencyReason QPN)++-- | The information needed to create a 'Fail' node.+type Conflict = (ConflictSet, FailReason)++validate :: Tree d c -> Validate (Tree d c)+validate = cata go+  where+    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)++    go (PChoiceF qpn rdm gr       ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts)+    go (FChoiceF qfn rdm gr b m d ts) =+      do+        -- Flag choices may occur repeatedly (because they can introduce new constraints+        -- in various places). However, subsequent choices must be consistent. We thereby+        -- collapse repeated flag choice nodes.+        PA _ pfa _ <- asks pa -- obtain current flag-preassignment+        case M.lookup qfn pfa of+          Just rb -> -- flag has already been assigned; collapse choice to the correct branch+                     case W.lookup rb ts of+                       Just t  -> goF qfn rb t+                       Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn)+          Nothing -> -- flag choice is new, follow both branches+                     FChoice qfn rdm gr b m d <$> sequence (W.mapWithKey (goF qfn) ts)+    go (SChoiceF qsn rdm gr b   ts) =+      do+        -- Optional stanza choices are very similar to flag choices.+        PA _ _ psa <- asks pa -- obtain current stanza-preassignment+        case M.lookup qsn psa of+          Just rb -> -- stanza choice has already been made; collapse choice to the correct branch+                     case W.lookup rb ts of+                       Just t  -> goS qsn rb t+                       Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn)+          Nothing -> -- stanza choice is new, follow both branches+                     SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts)++    -- We don't need to do anything for goal choices or failure nodes.+    go (GoalChoiceF rdm           ts) = GoalChoice rdm <$> sequence ts+    go (DoneF       rdm s           ) = pure (Done rdm s)+    go (FailF    c fr               ) = pure (Fail c fr)++    -- What to do for package nodes ...+    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)+    goP qpn@(Q _pp pn) (POption i _) r = do+      PA ppa pfa psa <- asks pa    -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs+      idx            <- asks index -- obtain the index+      svd            <- asks saved -- obtain saved dependencies+      aComps         <- asks availableComponents+      rComps         <- asks requiredComponents+      qo             <- asks qualifyOptions+      -- obtain dependencies and index-dictated exclusions introduced by the choice+      let (PInfo deps comps _ mfr) = idx ! pn ! i+      -- qualify the deps in the current scope+      let qdeps = qualifyDeps qo qpn deps+      -- the new active constraints are given by the instance we have chosen,+      -- plus the dependency information we have for that instance+      let newactives = extractAllDeps pfa psa qdeps+      -- We now try to extend the partial assignment with the new active constraints.+      let mnppa = extend extSupported langSupported pkgPresent newactives+                   =<< extendWithPackageChoice (PI qpn i) ppa+      -- In case we continue, we save the scoped dependencies+      let nsvd = M.insert qpn qdeps svd+      case mfr of+        Just fr -> -- The index marks this as an invalid choice. We can stop.+                   return (Fail (varToConflictSet (P qpn)) fr)+        Nothing ->+          let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons)+              newDeps = do+                nppa <- mnppa+                rComps' <- extendRequiredComponents qpn aComps rComps newactives+                checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps+                return (nppa, rComps')+          in case newDeps of+               Left (c, fr)          -> -- We have an inconsistency. We can stop.+                                        return (Fail c fr)+               Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation.+                                        local (\ s -> s { pa = PA nppa pfa psa+                                                        , saved = nsvd+                                                        , availableComponents = M.insert qpn comps aComps+                                                        , requiredComponents = rComps'+                                                        }) r++    -- What to do for flag nodes ...+    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goF qfn@(FN qpn _f) b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs   -- obtain the present pkg-config pkgs+      svd            <- asks saved         -- obtain saved dependencies+      aComps         <- asks availableComponents+      rComps         <- asks requiredComponents+      -- Note that there should be saved dependencies for the package in question,+      -- because while building, we do not choose flags before we see the packages+      -- that define them.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npfa = M.insert qfn b pfa+      -- We now try to get the new active dependencies we might learn about because+      -- we have chosen a new flag.+      let newactives = extractNewDeps (F qfn) b npfa psa qdeps+          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives+      -- As in the package case, we try to extend the partial assignment.+      let mnppa = extend extSupported langSupported pkgPresent newactives ppa+      case liftM2 (,) mnppa mNewRequiredComps of+        Left (c, fr)         -> return (Fail c fr) -- inconsistency found+        Right (nppa, rComps') ->+            local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r++    -- What to do for stanza nodes (similar to flag nodes) ...+    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)+    goS qsn@(SN qpn _f) b r = do+      PA ppa pfa psa <- asks pa -- obtain current preassignment+      extSupported   <- asks supportedExt  -- obtain the supported extensions+      langSupported  <- asks supportedLang -- obtain the supported languages+      pkgPresent     <- asks presentPkgs -- obtain the present pkg-config pkgs+      svd            <- asks saved         -- obtain saved dependencies+      aComps         <- asks availableComponents+      rComps         <- asks requiredComponents+      -- Note that there should be saved dependencies for the package in question,+      -- because while building, we do not choose flags before we see the packages+      -- that define them.+      let qdeps = svd ! qpn+      -- We take the *saved* dependencies, because these have been qualified in the+      -- correct scope.+      --+      -- Extend the flag assignment+      let npsa = M.insert qsn b psa+      -- We now try to get the new active dependencies we might learn about because+      -- we have chosen a new flag.+      let newactives = extractNewDeps (S qsn) b pfa npsa qdeps+          mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives+      -- As in the package case, we try to extend the partial assignment.+      let mnppa = extend extSupported langSupported pkgPresent newactives ppa+      case liftM2 (,) mnppa mNewRequiredComps of+        Left (c, fr)         -> return (Fail c fr) -- inconsistency found+        Right (nppa, rComps') ->+            local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r++-- | Check that a newly chosen package instance contains all components that+-- are required from that package so far. The components must also be visible+-- and buildable.+checkComponentsInNewPackage :: ComponentDependencyReasons+                            -> QPN+                            -> Map ExposedComponent ComponentInfo+                            -> Either Conflict ()+checkComponentsInNewPackage required qpn providedComps =+    case M.toList $ deleteKeys (M.keys providedComps) required of+      (missingComp, dr) : _ ->+          Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent+      []                    ->+          let failures = lefts+                  [ case () of+                      _ | compIsVisible compInfo == IsVisible False ->+                          Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent+                        | compIsBuildable compInfo == IsBuildable False ->+                          Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent+                        | otherwise -> Right ()+                  | let merged = M.intersectionWith (,) required providedComps+                  , (comp, (dr, compInfo)) <- M.toList merged ]+          in case failures of+               failure : _ -> Left failure+               []          -> Right ()+  where+    mkConflict :: ExposedComponent+               -> DependencyReason QPN+               -> (ExposedComponent -> DependencyReason QPN -> FailReason)+               -> Conflict+    mkConflict comp dr mkFailure =+        (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr)++    deleteKeys :: Ord k => [k] -> Map k v -> Map k v+    deleteKeys ks m = L.foldr M.delete m ks++-- | We try to extract as many concrete dependencies from the given flagged+-- dependencies as possible. We make use of all the flag knowledge we have+-- already acquired.+extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]+extractAllDeps fa sa deps = do+  d <- deps+  case d of+    Simple sd _         -> return sd+    Flagged qfn _ td fd -> case M.lookup qfn fa of+                             Nothing    -> mzero+                             Just True  -> extractAllDeps fa sa td+                             Just False -> extractAllDeps fa sa fd+    Stanza qsn td       -> case M.lookup qsn sa of+                             Nothing    -> mzero+                             Just True  -> extractAllDeps fa sa td+                             Just False -> []++-- | We try to find new dependencies that become available due to the given+-- flag or stanza choice. We therefore look for the choice in question, and then call+-- 'extractAllDeps' for everything underneath.+extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN]+extractNewDeps v b fa sa = go+  where+    go :: FlaggedDeps QPN -> [LDep QPN]+    go deps = do+      d <- deps+      case d of+        Simple _ _           -> mzero+        Flagged qfn' _ td fd+          | v == F qfn'      -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd+          | otherwise        -> case M.lookup qfn' fa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> go fd+        Stanza qsn' td+          | v == S qsn'      -> if b then extractAllDeps fa sa td else []+          | otherwise        -> case M.lookup qsn' sa of+                                  Nothing    -> mzero+                                  Just True  -> go td+                                  Just False -> []++-- | Extend a package preassignment.+--+-- Takes the variable that causes the new constraints, a current preassignment+-- and a set of new dependency constraints.+--+-- We're trying to extend the preassignment with each dependency one by one.+-- Each dependency is for a particular variable. We check if we already have+-- constraints for that variable in the current preassignment. If so, we're+-- trying to merge the constraints.+--+-- Either returns a witness of the conflict that would arise during the merge,+-- or the successfully extended assignment.+extend :: (Extension -> Bool)            -- ^ is a given extension supported+       -> (Language  -> Bool)            -- ^ is a given language supported+       -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable+       -> [LDep QPN]+       -> PPreAssignment+       -> Either Conflict PPreAssignment+extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives+  where++    extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment+    extendSingle a (LDep dr (Ext  ext ))  =+      if extSupported  ext  then Right a+                            else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext)+    extendSingle a (LDep dr (Lang lang))  =+      if langSupported lang then Right a+                            else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang)+    extendSingle a (LDep dr (Pkg pn vr))  =+      if pkgPresent pn vr then Right a+                          else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr)+    extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) =+      let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a+      in  case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of+            Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')+            Right x           -> Right x++-- | Extend a package preassignment with a package choice. For example, when+-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.+--+-- TODO: The new constraint is implemented as a dependency from foo to foo's+-- main library. That isn't correct, because foo might only be needed as a build+-- tool dependency. The implemention may need to change when we support+-- component-based dependency solving.+extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment+extendWithPackageChoice (PI qpn i) ppa =+  let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa+      newChoice = PkgDep (DependencyReason qpn M.empty S.empty)+                         (PkgComponent qpn (ExposedLib LMainLibName))+                         (Fixed i)+  in  case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of+        Left (c, (d, _d')) -> -- Don't include the package choice in the+                              -- FailReason, because it is redundant.+                              Left (c, NewPackageDoesNotMatchExistingConstraint d)+        Right x            -> Right x++-- | Merge constrained instances. We currently adopt a lazy strategy for+-- merging, i.e., we only perform actual checking if one of the two choices+-- is fixed. If the merge fails, we return a conflict set indicating the+-- variables responsible for the failure, as well as the two conflicting+-- fragments.+--+-- Note that while there may be more than one conflicting pair of version+-- ranges, we only return the first we find.+--+-- The ConflictingDeps are returned in order, i.e., the first describes the+-- conflicting part of the MergedPkgDep, and the second describes the PkgDep.+--+-- TODO: Different pairs might have different conflict sets. We're+-- obviously interested to return a conflict that has a "better" conflict+-- set in the sense the it contains variables that allow us to backjump+-- further. We might apply some heuristics here, such as to change the+-- order in which we check the constraints.+merge ::+#ifdef DEBUG_CONFLICT_SETS+  (?loc :: CallStack) =>+#endif+  MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep+merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2))+  | i1 == i2  = Right $ MergedDepFixed comp1 vs1 i1+  | otherwise =+      Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2+           , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1)+             , ConflictingDep vs2 (PkgComponent p comp2) ci ) )++merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr))+  | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i+  | otherwise    =+      Left ( createConflictSetForVersionConflict p v vs1 vr vs2+           , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i)+             , ConflictingDep vs2 (PkgComponent p comp2) ci ) )++merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) =+    go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...+  where+    go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep+    go [] = Right (MergedDepFixed comp2 vs2 i)+    go ((vr, comp1, vs1) : vros)+       | checkVR vr v = go vros+       | otherwise    =+           Left ( createConflictSetForVersionConflict p v vs2 vr vs1+                , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr)+                  , ConflictingDep vs2 (PkgComponent p comp2) ci ) )++merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) =+    Right (MergedDepConstrained $++    -- TODO: This line appends the new version range, to preserve the order used+    -- before a refactoring. Consider prepending the version range, if there is+    -- no negative performance impact.+    vrOrigins ++ [(vr, comp2, vs2)])++-- | Creates a conflict set representing a conflict between a version constraint+-- and the fixed version chosen for a package.+createConflictSetForVersionConflict :: QPN+                                    -> Ver+                                    -> DependencyReason QPN+                                    -> VR+                                    -> DependencyReason QPN+                                    -> ConflictSet+createConflictSetForVersionConflict pkg+                                    conflictingVersion+                                    versionDR@(DependencyReason p1 _ _)+                                    conflictingVersionRange+                                    versionRangeDR@(DependencyReason p2 _ _) =+  let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss)+  in+    -- The solver currently only optimizes the case where there is a conflict+    -- between the version chosen for a package and a version constraint that+    -- is not under any flags or stanzas. Here is how we check for this case:+    --+    --   (1) Choosing a specific version for a package foo is implemented as+    --       adding a dependency from foo to that version of foo (See+    --       extendWithPackageChoice), so we check that the DependencyReason+    --       contains the current package and no flag or stanza choices.+    --+    --   (2) We check that the DependencyReason for the version constraint also+    --       contains no flag or stanza choices.+    --+    -- When these criteria are not met, we fall back to calling+    -- dependencyReasonToConflictSet.+    if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR)+    then let cs1 = dependencyReasonToConflictSetWithVersionConflict+                   p2+                   (CS.OrderedVersionRange conflictingVersionRange)+                   versionDR+             cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict+                   pkg conflictingVersion versionRangeDR+         in cs1 `CS.union` cs2+    else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR++-- | Takes a list of new dependencies and uses it to try to update the map of+-- known component dependencies. It returns a failure when a new dependency+-- requires a component that is missing, private, or unbuildable in a previously+-- chosen package.+extendRequiredComponents :: QPN -- ^ package we extend+                         -> Map QPN (Map ExposedComponent ComponentInfo)+                         -> Map QPN ComponentDependencyReasons+                         -> [LDep QPN]+                         -> Either Conflict (Map QPN ComponentDependencyReasons)+extendRequiredComponents eqpn available = foldM extendSingle+  where+    extendSingle :: Map QPN ComponentDependencyReasons+                 -> LDep QPN+                 -> Either Conflict (Map QPN ComponentDependencyReasons)+    extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) =+      let compDeps = M.findWithDefault M.empty qpn required+          success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required+      in -- Only check for the existence of the component if its package has+         -- already been chosen.+         case M.lookup qpn available of+           Just comps ->+               case M.lookup comp comps of+                 Nothing ->+                     Left $ mkConflict qpn comp dr PackageRequiresMissingComponent+                 Just compInfo+                   | compIsVisible compInfo == IsVisible False+                   , eqpn /= qpn -- package components can depend on other components+                   ->+                     Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent+                   | compIsBuildable compInfo == IsBuildable False ->+                     Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent+                   | otherwise -> success+           Nothing    -> success+    extendSingle required _                                         = Right required++    mkConflict :: QPN+               -> ExposedComponent+               -> DependencyReason QPN+               -> (QPN -> ExposedComponent -> FailReason)+               -> Conflict+    mkConflict qpn comp dr mkFailure =+      (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp)+++-- | Interface.+validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c+validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {+    supportedExt        = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported+                                (\ es -> let s = S.fromList es in \ x -> S.member x s)+                                (compilerInfoExtensions cinfo)+  , supportedLang       = maybe (const True)+                                (flip L.elem) -- use list lookup because language list is small and no Ord instance+                                (compilerInfoLanguages  cinfo)+  , presentPkgs         = pkgConfigPkgIsPresent pkgConfigDb+  , index               = idx+  , saved               = M.empty+  , pa                  = PA M.empty M.empty M.empty+  , availableComponents = M.empty+  , requiredComponents  = M.empty+  , qualifyOptions      = defaultQualifyOptions idx+  }
+ cabal-install-solver/src/Distribution/Solver/Modular/Var.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Solver.Modular.Var (+    Var(..)+  , showVar+  , varPN+  ) where++import Prelude hiding (pi)++import Distribution.Solver.Modular.Flag+import Distribution.Solver.Types.PackagePath++{-------------------------------------------------------------------------------+  Variables+-------------------------------------------------------------------------------}++-- | The type of variables that play a role in the solver.+-- Note that the tree currently does not use this type directly,+-- and rather has separate tree nodes for the different types of+-- variables. This fits better with the fact that in most cases,+-- these have to be treated differently.+data Var qpn = P qpn | F (FN qpn) | S (SN qpn)+  deriving (Eq, Ord, Show, Functor)++showVar :: Var QPN -> String+showVar (P qpn) = showQPN qpn+showVar (F qfn) = showQFN qfn+showVar (S qsn) = showQSN qsn++-- | Extract the package name from a Var+varPN :: Var qpn -> qpn+varPN (P qpn)        = qpn+varPN (F (FN qpn _)) = qpn+varPN (S (SN qpn _)) = qpn
+ cabal-install-solver/src/Distribution/Solver/Modular/Version.hs view
@@ -0,0 +1,56 @@+module Distribution.Solver.Modular.Version+    ( Ver+    , VR+    , anyVR+    , checkVR+    , eqVR+    , showVer+    , showVR+    , simplifyVR+    , (.&&.)+    , (.||.)+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import qualified Distribution.Version as CV -- from Cabal+import Distribution.Pretty (prettyShow)++-- | Preliminary type for versions.+type Ver = CV.Version++-- | String representation of a version.+showVer :: Ver -> String+showVer = prettyShow++-- | Version range. Consists of a lower and upper bound.+type VR = CV.VersionRange++-- | String representation of a version range.+showVR :: VR -> String+showVR = prettyShow++-- | Unconstrained version range.+anyVR :: VR+anyVR = CV.anyVersion++-- | Version range fixing a single version.+eqVR :: Ver -> VR+eqVR = CV.thisVersion++-- | Intersect two version ranges.+(.&&.) :: VR -> VR -> VR+v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2++-- | Union of two version ranges.+(.||.) :: VR -> VR -> VR+v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2++-- | Simplify a version range.+simplifyVR :: VR -> VR+simplifyVR = CV.simplifyVersionRange++-- | Checking a version against a version range.+checkVR :: VR -> Ver -> Bool+checkVR = flip CV.withinRange
+ cabal-install-solver/src/Distribution/Solver/Modular/WeightedPSQ.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Solver.Modular.WeightedPSQ (+    WeightedPSQ+  , fromList+  , toList+  , keys+  , weights+  , isZeroOrOne+  , filter+  , lookup+  , mapWithKey+  , mapWeightsWithKey+  , union+  , takeUntil+  ) where++import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Ord (comparing)+import qualified Data.Traversable as T+import Prelude hiding (filter, lookup)++-- | An association list that is sorted by weight.+--+-- Each element has a key ('k'), value ('v'), and weight ('w'). All operations+-- that add elements or modify weights stably sort the elements by weight.+newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)]+  deriving (Eq, Show, Functor, F.Foldable, T.Traversable)++-- | /O(N)/.+filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v+filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs)++-- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements.+isZeroOrOne :: WeightedPSQ w k v -> Bool+isZeroOrOne (WeightedPSQ [])  = True+isZeroOrOne (WeightedPSQ [_]) = True+isZeroOrOne _                 = False++-- | /O(1)/. Return the elements in order.+toList :: WeightedPSQ w k v -> [(w, k, v)]+toList (WeightedPSQ xs) = xs++-- | /O(N log N)/.+fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v+fromList = WeightedPSQ . L.sortBy (comparing triple_1)++-- | /O(N)/. Return the weights in order.+weights :: WeightedPSQ w k v -> [w]+weights (WeightedPSQ xs) = L.map triple_1 xs++-- | /O(N)/. Return the keys in order.+keys :: WeightedPSQ w k v -> [k]+keys (WeightedPSQ xs) = L.map triple_2 xs++-- | /O(N)/. Return the value associated with the first occurrence of the give+-- key, if it exists.+lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v+lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs++-- | /O(N log N)/. Update the weights.+mapWeightsWithKey :: Ord w2+                  => (k -> w1 -> w2)+                  -> WeightedPSQ w1 k v+                  -> WeightedPSQ w2 k v+mapWeightsWithKey f (WeightedPSQ xs) = fromList $+                                       L.map (\ (w, k, v) -> (f k w, k, v)) xs++-- | /O(N)/. Update the values.+mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2+mapWithKey f (WeightedPSQ xs) = WeightedPSQ $+                                L.map (\ (w, k, v) -> (w, k, f k v)) xs++-- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all+-- elements. Elements from the first @WeightedPSQ@ come before elements in the+-- second when they have the same weight.+union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v+union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys)++-- | /O(N)/. Return the prefix of values ending with the first element that+-- satisfies p, or all elements if none satisfy p.+takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v+takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs)+  where+    go :: [(w, k, v)] -> [(w, k, v)]+    go []       = []+    go (y : ys) = y : if p (triple_3 y) then [] else go ys++triple_1 :: (x, y, z) -> x+triple_1 (x, _, _) = x++triple_2 :: (x, y, z) -> y+triple_2 (_, y, _) = y++triple_3 :: (x, y, z) -> z+triple_3 (_, _, z) = z
+ cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++-- | Fine-grained package dependencies+--+-- Like many others, this module is meant to be "double-imported":+--+-- > import Distribution.Solver.Types.ComponentDeps (+-- >     Component+-- >   , ComponentDep+-- >   , ComponentDeps+-- >   )+-- > import qualified Distribution.Solver.Types.ComponentDeps as CD+module Distribution.Solver.Types.ComponentDeps (+    -- * Fine-grained package dependencies+    Component(..)+  , componentNameToComponent+  , ComponentDep+  , ComponentDeps -- opaque+    -- ** Constructing ComponentDeps+  , empty+  , fromList+  , singleton+  , insert+  , zip+  , filterDeps+  , fromLibraryDeps+  , fromSetupDeps+  , fromInstalled+    -- ** Deconstructing ComponentDeps+  , toList+  , flatDeps+  , nonSetupDeps+  , libraryDeps+  , setupDeps+  , select+  , components+  ) where++import Prelude ()+import Distribution.Types.UnqualComponentName+import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip)++import qualified Data.Map as Map+import Data.Foldable (fold)++import Distribution.Pretty (Pretty (..))+import qualified Distribution.Types.ComponentName as CN+import qualified Distribution.Types.LibraryName as LN+import qualified Text.PrettyPrint as PP+++{-------------------------------------------------------------------------------+  Types+-------------------------------------------------------------------------------}++-- | Component of a package.+data Component =+    ComponentLib+  | ComponentSubLib UnqualComponentName+  | ComponentFLib   UnqualComponentName+  | ComponentExe    UnqualComponentName+  | ComponentTest   UnqualComponentName+  | ComponentBench  UnqualComponentName+  | ComponentSetup+  deriving (Show, Eq, Ord, Generic)++instance Binary Component+instance Structured Component++instance Pretty Component where+    pretty ComponentLib        = PP.text "lib"+    pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n+    pretty (ComponentFLib n)   = PP.text "flib:" <<>> pretty n+    pretty (ComponentExe n)    = PP.text "exe:" <<>> pretty n+    pretty (ComponentTest n)   = PP.text "test:" <<>> pretty n+    pretty (ComponentBench n)  = PP.text "bench:" <<>> pretty n+    pretty ComponentSetup      = PP.text "setup"++-- | Dependency for a single component.+type ComponentDep a = (Component, a)++-- | Fine-grained dependencies for a package.+--+-- Typically used as @ComponentDeps [Dependency]@, to represent the list of+-- dependencies for each named component within a package.+--+newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }+  deriving (Show, Functor, Eq, Ord, Generic)++instance Semigroup a => Monoid (ComponentDeps a) where+  mempty = ComponentDeps Map.empty+  mappend = (<>)++instance Semigroup a => Semigroup (ComponentDeps a) where+  ComponentDeps d <> ComponentDeps d' =+      ComponentDeps (Map.unionWith (<>) d d')++instance Foldable ComponentDeps where+  foldMap f = foldMap f . unComponentDeps++instance Traversable ComponentDeps where+  traverse f = fmap ComponentDeps . traverse f . unComponentDeps++instance Binary a => Binary (ComponentDeps a)+instance Structured a => Structured (ComponentDeps a)++componentNameToComponent :: CN.ComponentName -> Component+componentNameToComponent (CN.CLibName  LN.LMainLibName)   = ComponentLib+componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s+componentNameToComponent (CN.CFLibName                s)  = ComponentFLib   s+componentNameToComponent (CN.CExeName                 s)  = ComponentExe    s+componentNameToComponent (CN.CTestName                s)  = ComponentTest   s+componentNameToComponent (CN.CBenchName               s)  = ComponentBench  s++{-------------------------------------------------------------------------------+  Construction+-------------------------------------------------------------------------------}++empty :: ComponentDeps a+empty = ComponentDeps $ Map.empty++fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a+fromList = ComponentDeps . Map.fromListWith mappend++singleton :: Component -> a -> ComponentDeps a+singleton comp = ComponentDeps . Map.singleton comp++insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a+insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps+  where+    aux Nothing   = Just a+    aux (Just a') = Just $ a `mappend` a'++-- | Zip two 'ComponentDeps' together by 'Component', using 'mempty'+-- as the neutral element when a 'Component' is present only in one.+zip+  :: (Monoid a, Monoid b)+  => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)+zip (ComponentDeps d1) (ComponentDeps d2) =+    ComponentDeps $+      Map.mergeWithKey+        (\_ a b -> Just (a,b))+        (fmap (\a -> (a, mempty)))+        (fmap (\b -> (mempty, b)))+        d1 d2++-- | Keep only selected components (and their associated deps info).+filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a+filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps++-- | ComponentDeps containing library dependencies only+fromLibraryDeps :: a -> ComponentDeps a+fromLibraryDeps = singleton ComponentLib++-- | ComponentDeps containing setup dependencies only.+fromSetupDeps :: a -> ComponentDeps a+fromSetupDeps = singleton ComponentSetup++-- | ComponentDeps for installed packages.+--+-- We assume that installed packages only record their library dependencies.+fromInstalled :: a -> ComponentDeps a+fromInstalled = fromLibraryDeps++{-------------------------------------------------------------------------------+  Deconstruction+-------------------------------------------------------------------------------}++toList :: ComponentDeps a -> [ComponentDep a]+toList = Map.toList . unComponentDeps++-- | All dependencies of a package.+--+-- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more+-- obvious than a use of 'fold', and moreover this avoids introducing lots of+-- @#ifdef@s for 7.10 just for the use of 'fold'.+flatDeps :: Monoid a => ComponentDeps a -> a+flatDeps = fold++-- | All dependencies except the setup dependencies.+--+-- Prior to the introduction of setup dependencies in version 1.24 this+-- would have been _all_ dependencies.+nonSetupDeps :: Monoid a => ComponentDeps a -> a+nonSetupDeps = select (/= ComponentSetup)++-- | Library dependencies proper only.  (Includes dependencies+-- of internal libraries.)+libraryDeps :: Monoid a => ComponentDeps a -> a+libraryDeps = select (\c -> case c of ComponentSubLib _ -> True+                                      ComponentLib -> True+                                      _ -> False)++-- | List components+components :: ComponentDeps a -> Set Component+components = Map.keysSet . unComponentDeps++-- | Setup dependencies.+setupDeps :: Monoid a => ComponentDeps a -> a+setupDeps = select (== ComponentSetup)++-- | Select dependencies satisfying a given predicate.+select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a+select p = foldMap snd . filter (p . fst) . toList
+ cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.ConstraintSource+    ( ConstraintSource(..)+    , showConstraintSource+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++-- | Source of a 'PackageConstraint'.+data ConstraintSource =++  -- | Main config file, which is ~/.cabal/config by default.+  ConstraintSourceMainConfig FilePath++  -- | Local cabal.project file+  | ConstraintSourceProjectConfig FilePath++  -- | Sandbox config file, which is ./cabal.sandbox.config by default.+  | ConstraintSourceSandboxConfig FilePath++  -- | User config file, which is ./cabal.config by default.+  | ConstraintSourceUserConfig FilePath++  -- | Flag specified on the command line.+  | ConstraintSourceCommandlineFlag++  -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@+  -- implies @package==0.1.0.0@.+  | ConstraintSourceUserTarget++  -- | Internal requirement to use installed versions of packages like ghc-prim.+  | ConstraintSourceNonUpgradeablePackage++  -- | Internal requirement to use the add-source version of a package when that+  -- version is installed and the source is modified.+  | ConstraintSourceModifiedAddSourceDep++  -- | Internal constraint used by @cabal freeze@.+  | ConstraintSourceFreeze++  -- | Constraint specified by a config file, a command line flag, or a user+  -- target, when a more specific source is not known.+  | ConstraintSourceConfigFlagOrTarget++  -- | The source of the constraint is not specified.+  | ConstraintSourceUnknown++  -- | An internal constraint due to compatibility issues with the Setup.hs+  -- command line interface requires a minimum lower bound on Cabal+  | ConstraintSetupCabalMinVersion++  -- | An internal constraint due to compatibility issues with the Setup.hs+  -- command line interface requires a maximum upper bound on Cabal+  | ConstraintSetupCabalMaxVersion+  deriving (Eq, Show, Generic)++instance Binary ConstraintSource+instance Structured ConstraintSource++-- | Description of a 'ConstraintSource'.+showConstraintSource :: ConstraintSource -> String+showConstraintSource (ConstraintSourceMainConfig path) =+    "main config " ++ path+showConstraintSource (ConstraintSourceProjectConfig path) =+    "project config " ++ path+showConstraintSource (ConstraintSourceSandboxConfig path) =+    "sandbox config " ++ path+showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path+showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"+showConstraintSource ConstraintSourceUserTarget = "user target"+showConstraintSource ConstraintSourceNonUpgradeablePackage =+    "non-upgradeable package"+showConstraintSource ConstraintSourceModifiedAddSourceDep =+    "modified add-source dependency"+showConstraintSource ConstraintSourceFreeze = "cabal freeze"+showConstraintSource ConstraintSourceConfigFlagOrTarget =+    "config file, command line flag, or user target"+showConstraintSource ConstraintSourceUnknown = "unknown source"+showConstraintSource ConstraintSetupCabalMinVersion =+    "minimum version of Cabal used by Setup.hs"+showConstraintSource ConstraintSetupCabalMaxVersion =+    "maximum version of Cabal used by Setup.hs"
+ cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs view
@@ -0,0 +1,37 @@+module Distribution.Solver.Types.DependencyResolver+    ( DependencyResolver+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb )+import Distribution.Solver.Types.PackagePreferences+import Distribution.Solver.Types.PackageIndex ( PackageIndex )+import Distribution.Solver.Types.Progress+import Distribution.Solver.Types.ResolverPackage+import Distribution.Solver.Types.SourcePackage++import Distribution.Simple.PackageIndex ( InstalledPackageIndex )+import Distribution.Package ( PackageName )+import Distribution.Compiler ( CompilerInfo )+import Distribution.System ( Platform )++-- | A dependency resolver is a function that works out an installation plan+-- given the set of installed and available packages and a set of deps to+-- solve for.+--+-- The reason for this interface is because there are dozens of approaches to+-- solving the package dependency problem and we want to make it easy to swap+-- in alternatives.+--+type DependencyResolver loc = Platform+                           -> CompilerInfo+                           -> InstalledPackageIndex+                           -> PackageIndex (SourcePackage loc)+                           -> PkgConfigDb+                           -> (PackageName -> PackagePreferences)+                           -> [LabeledPackageConstraint]+                           -> Set PackageName+                           -> Progress String String [ResolverPackage loc]
+ cabal-install-solver/src/Distribution/Solver/Types/Flag.hs view
@@ -0,0 +1,8 @@+module Distribution.Solver.Types.Flag+    ( FlagType(..)+    ) where++import Prelude (Eq, Show)++data FlagType = Manual | Automatic+  deriving (Eq, Show)
+ cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.InstSolverPackage+    ( InstSolverPackage(..)+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) )+import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )+import Distribution.Solver.Types.SolverId+import Distribution.Types.MungedPackageId+import Distribution.Types.PackageId+import Distribution.Types.MungedPackageName+import Distribution.InstalledPackageInfo (InstalledPackageInfo)++-- | An 'InstSolverPackage' is a pre-existing installed package+-- specified by the dependency solver.+data InstSolverPackage = InstSolverPackage {+      instSolverPkgIPI :: InstalledPackageInfo,+      instSolverPkgLibDeps :: ComponentDeps [SolverId],+      instSolverPkgExeDeps :: ComponentDeps [SolverId]+    }+  deriving (Eq, Show, Generic)++instance Binary InstSolverPackage+instance Structured InstSolverPackage++instance Package InstSolverPackage where+    packageId i =+        -- HACK! See Note [Index conversion with internal libraries]+        let MungedPackageId mpn v = mungedId i+        in PackageIdentifier (encodeCompatPackageName mpn) v++instance HasMungedPackageId InstSolverPackage where+    mungedId = mungedId . instSolverPkgIPI++instance HasUnitId InstSolverPackage where+    installedUnitId = installedUnitId . instSolverPkgIPI
+ cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs view
@@ -0,0 +1,11 @@+module Distribution.Solver.Types.InstalledPreference+    ( InstalledPreference(..),+    ) where++import Prelude (Show)++-- | Whether we prefer an installed version of a package or simply the latest+-- version.+--+data InstalledPreference = PreferInstalled | PreferLatest+  deriving Show
+ cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs view
@@ -0,0 +1,14 @@+module Distribution.Solver.Types.LabeledPackageConstraint+    ( LabeledPackageConstraint(..)+    , unlabelPackageConstraint+    ) where++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.PackageConstraint++-- | 'PackageConstraint' labeled with its source.+data LabeledPackageConstraint+   = LabeledPackageConstraint PackageConstraint ConstraintSource++unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint+unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
+ cabal-install-solver/src/Distribution/Solver/Types/OptionalStanza.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+module Distribution.Solver.Types.OptionalStanza (+    -- * OptionalStanza+    OptionalStanza(..),+    showStanza,+    showStanzas,+    enableStanzas,+    -- * Set of stanzas+    OptionalStanzaSet,+    optStanzaSetFromList,+    optStanzaSetToList,+    optStanzaSetMember,+    optStanzaSetInsert,+    optStanzaSetSingleton,+    optStanzaSetIntersection,+    optStanzaSetNull,+    optStanzaSetIsSubset,+    -- * Map indexed by stanzas+    OptionalStanzaMap,+    optStanzaTabulate,+    optStanzaIndex,+    optStanzaLookup,+    optStanzaKeysFilteredByValue,+) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Data.Bits                                 (testBit, (.|.), (.&.))+import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..))+import Distribution.Utils.Structured (Structured (..), nominalStructure)++-------------------------------------------------------------------------------+-- OptionalStanza+-------------------------------------------------------------------------------++data OptionalStanza+    = TestStanzas+    | BenchStanzas+  deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable)++-- | String representation of an OptionalStanza.+showStanza :: OptionalStanza -> String+showStanza TestStanzas  = "test"+showStanza BenchStanzas = "bench"++showStanzas :: OptionalStanzaSet -> String+showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList++-- | Convert a list of 'OptionalStanza' into the corresponding+-- Cabal's 'ComponentRequestedSpec' which records what components are enabled.+--+enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec+enableStanzas optionalStanzas = ComponentRequestedSpec+    { testsRequested      = optStanzaSetMember TestStanzas  optionalStanzas+    , benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas+    }++instance Binary OptionalStanza+instance Structured OptionalStanza++-------------------------------------------------------------------------------+-- OptionalStanzaSet+-------------------------------------------------------------------------------++newtype OptionalStanzaSet = OptionalStanzaSet Word+  deriving (Eq, Ord, Show)++instance Binary OptionalStanzaSet where+    put (OptionalStanzaSet w) = put w+    get = fmap (OptionalStanzaSet . (.&. 0x03)) get++instance Structured OptionalStanzaSet where+    structure = nominalStructure++optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet+optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty++optStanzaSetToList :: OptionalStanzaSet -> [OptionalStanza]+optStanzaSetToList (OptionalStanzaSet 0) = []+optStanzaSetToList (OptionalStanzaSet 1) = [TestStanzas]+optStanzaSetToList (OptionalStanzaSet 2) = [BenchStanzas]+optStanzaSetToList (OptionalStanzaSet 3) = [TestStanzas, BenchStanzas]+optStanzaSetToList (OptionalStanzaSet _) = []++optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet+optStanzaSetInsert x s = optStanzaSetSingleton x <> s++optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool+optStanzaSetMember TestStanzas  (OptionalStanzaSet w) = testBit w 0+optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1++optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet+optStanzaSetSingleton TestStanzas  = OptionalStanzaSet 1+optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2++optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet+optStanzaSetIntersection (OptionalStanzaSet a) (OptionalStanzaSet b) = OptionalStanzaSet (a .&. b)++optStanzaSetNull :: OptionalStanzaSet -> Bool+optStanzaSetNull (OptionalStanzaSet w) = w == 0++optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool+optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b++instance Semigroup OptionalStanzaSet where+    OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b)++instance Monoid OptionalStanzaSet where+    mempty = OptionalStanzaSet 0+    mappend = (<>)++-------------------------------------------------------------------------------+-- OptionalStanzaMap+-------------------------------------------------------------------------------++-- | Note: this is total map.+data OptionalStanzaMap a = OptionalStanzaMap a a+  deriving (Eq, Ord, Show, Generic)++instance Binary a => Binary (OptionalStanzaMap a)+instance Structured a => Structured (OptionalStanzaMap a)++optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a+optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas)++optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a+optStanzaIndex (OptionalStanzaMap x _) TestStanzas  = x+optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x++optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a+optStanzaLookup = flip optStanzaIndex++optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet+optStanzaKeysFilteredByValue p (OptionalStanzaMap x y)+    | p x       = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1+    | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0
+ cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveGeneric #-}++-- | Per-package constraints. Package constraints must be respected by the+-- solver. Multiple constraints for each package can be given, though obviously+-- it is possible to construct conflicting constraints (eg impossible version+-- range or inconsistent flag assignment).+--+module Distribution.Solver.Types.PackageConstraint (+    ConstraintScope(..),+    scopeToplevel,+    scopeToPackageName,+    constraintScopeMatches,+    PackageProperty(..),+    dispPackageProperty,+    PackageConstraint(..),+    dispPackageConstraint,+    showPackageConstraint,+    packageConstraintToDependency+  ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Package                        (PackageName)+import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)+import Distribution.Pretty                         (flatStyle, pretty)+import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))+import Distribution.Version                        (VersionRange, simplifyVersionRange)++import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PackagePath++import qualified Text.PrettyPrint as Disp+++-- | Determines to what packages and in what contexts a+-- constraint applies.+data ConstraintScope+     -- | A scope that applies when the given package is used as a build target.+     -- In other words, the scope applies iff a goal has a top-level qualifier+     -- and its namespace matches the given package name. A namespace is+     -- considered to match a package name when it is either the default+     -- namespace (for --no-independent-goals) or it is an independent namespace+     -- with the given package name (for --independent-goals).++     -- TODO: Try to generalize the ConstraintScopes once component-based+     -- solving is implemented, and remove this special case for targets.+   = ScopeTarget PackageName+     -- | The package with the specified name and qualifier.+   | ScopeQualified Qualifier PackageName+     -- | The package with the specified name when it has a+     -- setup qualifier.+   | ScopeAnySetupQualifier PackageName+     -- | The package with the specified name regardless of+     -- qualifier.+   | ScopeAnyQualifier PackageName+  deriving (Eq, Show)++-- | Constructor for a common use case: the constraint applies to+-- the package with the specified name when that package is a+-- top-level dependency in the default namespace.+scopeToplevel :: PackageName -> ConstraintScope+scopeToplevel = ScopeQualified QualToplevel++-- | Returns the package name associated with a constraint scope.+scopeToPackageName :: ConstraintScope -> PackageName+scopeToPackageName (ScopeTarget pn) = pn+scopeToPackageName (ScopeQualified _ pn) = pn+scopeToPackageName (ScopeAnySetupQualifier pn) = pn+scopeToPackageName (ScopeAnyQualifier pn) = pn++constraintScopeMatches :: ConstraintScope -> QPN -> Bool+constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') =+  let namespaceMatches DefaultNamespace = True+      namespaceMatches (Independent namespacePn) = pn == namespacePn+  in namespaceMatches ns && q == QualToplevel && pn == pn'+constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') =+    q == q' && pn == pn'+constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =+  let setup (PackagePath _ (QualSetup _)) = True+      setup _                             = False+  in setup pp && pn == pn'+constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'++-- | Pretty-prints a constraint scope.+dispConstraintScope :: ConstraintScope -> Disp.Doc+dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn+dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn+dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn+dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn++-- | A package property is a logical predicate on packages.+data PackageProperty+   = PackagePropertyVersion   VersionRange+   | PackagePropertyInstalled+   | PackagePropertySource+   | PackagePropertyFlags     FlagAssignment+   | PackagePropertyStanzas   [OptionalStanza]+  deriving (Eq, Show, Generic)++instance Binary PackageProperty+instance Structured PackageProperty++-- | Pretty-prints a package property.+dispPackageProperty :: PackageProperty -> Disp.Doc+dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange+dispPackageProperty PackagePropertyInstalled          = Disp.text "installed"+dispPackageProperty PackagePropertySource             = Disp.text "source"+dispPackageProperty (PackagePropertyFlags flags)      = dispFlagAssignment flags+dispPackageProperty (PackagePropertyStanzas stanzas)  =+  Disp.hsep $ map (Disp.text . showStanza) stanzas++-- | A package constraint consists of a scope plus a property+-- that must hold for all packages within that scope.+data PackageConstraint = PackageConstraint ConstraintScope PackageProperty+  deriving (Eq, Show)++-- | Pretty-prints a package constraint.+dispPackageConstraint :: PackageConstraint -> Disp.Doc+dispPackageConstraint (PackageConstraint scope prop) =+  dispConstraintScope scope <+> dispPackageProperty prop++-- | Alternative textual representation of a package constraint+-- for debugging purposes (slightly more verbose than that+-- produced by 'dispPackageConstraint').+--+showPackageConstraint :: PackageConstraint -> String+showPackageConstraint pc@(PackageConstraint scope prop) =+  Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2+  where+    pc2 = case prop of+      PackagePropertyVersion vr ->+        PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr)+      _ -> pc+    postprocess = case prop of+      PackagePropertyFlags _ -> (Disp.text "flags" <+>)+      PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>)+      _ -> id++-- | Lossily convert a 'PackageConstraint' to a 'Dependency'.+packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint+packageConstraintToDependency (PackageConstraint scope prop) = toDep prop+  where+    toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr+    toDep (PackagePropertyInstalled)  = Nothing+    toDep (PackagePropertySource)     = Nothing+    toDep (PackagePropertyFlags _)    = Nothing+    toDep (PackagePropertyStanzas _)  = Nothing
+ cabal-install-solver/src/Distribution/Solver/Types/PackageFixedDeps.hs view
@@ -0,0 +1,23 @@+module Distribution.Solver.Types.PackageFixedDeps+    ( PackageFixedDeps(..)+    ) where++import           Distribution.InstalledPackageInfo ( InstalledPackageInfo )+import           Distribution.Package+                   ( Package(..), UnitId, installedDepends)+import           Distribution.Solver.Types.ComponentDeps ( ComponentDeps )+import qualified Distribution.Solver.Types.ComponentDeps as CD++-- | Subclass of packages that have specific versioned dependencies.+--+-- So for example a not-yet-configured package has dependencies on version+-- ranges, not specific versions. A configured or an already installed package+-- depends on exact versions. Some operations or data structures (like+--  dependency graphs) only make sense on this subclass of package types.+--+class Package pkg => PackageFixedDeps pkg where+  depends :: pkg -> ComponentDeps [UnitId]++instance PackageFixedDeps InstalledPackageInfo where+  depends pkg = CD.fromInstalled (installedDepends pkg)+
+ cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Solver.Types.PackageIndex+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- An index of packages.+--+module Distribution.Solver.Types.PackageIndex (+  -- * Package index data type+  PackageIndex,++  -- * Creating an index+  fromList,++  -- * Updates+  merge,+  override,+  insert,+  deletePackageName,+  deletePackageId,+  deleteDependency,++  -- * Queries++  -- ** Precise lookups+  elemByPackageId,+  elemByPackageName,+  lookupPackageName,+  lookupPackageId,+  lookupDependency,++  -- ** Case-insensitive searches+  searchByName,+  SearchResult(..),+  searchByNameSubstring,+  searchWithPredicate,++  -- ** Bulk queries+  allPackages,+  allPackagesByName,+  ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (lookup)++import qualified Data.Map as Map+import Data.List (isInfixOf)+import qualified Data.List.NonEmpty as NE++import Distribution.Client.Utils.Assertion ( expensiveAssert )+import Distribution.Package+         ( PackageName, unPackageName, PackageIdentifier(..)+         , Package(..), packageName, packageVersion )+import Distribution.Version+         ( VersionRange, withinRange )+import Distribution.Simple.Utils+         ( lowercase )++import qualified Prelude (foldr1)++-- | The collection of information about packages from one or more 'PackageDB's.+--+-- 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+  -- name case-sensitively. It includes all versions.+  --+  -- This allows us to find all versions satisfying a dependency.+  -- Most queries are a map lookup followed by a linear scan of the bucket.+  --+  (Map PackageName [pkg])++  deriving (Eq, Show, Read, Functor, Generic)+--FIXME: the Functor instance here relies on no package id changes++instance Package pkg => Semigroup (PackageIndex pkg) where+  (<>) = merge++instance Package pkg => Monoid (PackageIndex pkg) where+  mempty  = PackageIndex Map.empty+  mappend = (<>)+  --save one mappend with empty in the common case:+  mconcat [] = mempty+  mconcat xs = Prelude.foldr1 mappend xs++instance Binary pkg => Binary (PackageIndex pkg)++invariant :: Package pkg => PackageIndex pkg -> Bool+invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)+  where+    goodBucket _    [] = False+    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0+      where+        check pkgid []          = packageName pkgid == name+        check pkgid (pkg':pkgs) = packageName pkgid == name+                               && pkgid < pkgid'+                               && check pkgid' pkgs+          where pkgid' = packageId pkg'++--+-- * Internal helpers+--++mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg+mkPackageIndex index = expensiveAssert (invariant (PackageIndex index))+                                         (PackageIndex index)++internalError :: String -> a+internalError name = error ("PackageIndex." ++ name ++ ": internal error")++-- | Lookup a name in the index to get all packages that match that name+-- case-sensitively.+--+lookup :: PackageIndex pkg -> PackageName -> [pkg]+lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m++--+-- * Construction+--++-- | Build an index out of a bunch of packages.+--+-- If there are duplicates, later ones mask earlier ones.+--+fromList :: Package pkg => [pkg] -> PackageIndex pkg+fromList pkgs = mkPackageIndex+              . Map.map fixBucket+              . Map.fromListWith (++)+              $ [ (packageName pkg, [pkg])+                | pkg <- pkgs ]+  where+    fixBucket = -- out of groups of duplicates, later ones mask earlier ones+                -- but Map.fromListWith (++) constructs groups in reverse order+                map NE.head+                -- Eq instance for PackageIdentifier is wrong, so use Ord:+              . NE.groupBy (\a b -> EQ == comparing packageId a b)+                -- relies on sortBy being a stable sort so we+                -- can pick consistently among duplicates+              . sortBy (comparing packageId)++--+-- * Updates+--++-- | Merge two indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+merge i1@(PackageIndex m1) i2@(PackageIndex m2) =+  expensiveAssert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)+++-- | Elements in the second list mask those in the first.+mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]+mergeBuckets []     ys     = ys+mergeBuckets xs     []     = xs+mergeBuckets xs@(x:xs') ys@(y:ys') =+      case packageId x `compare` packageId y of+        GT -> y : mergeBuckets xs  ys'+        EQ -> y : mergeBuckets xs' ys'+        LT -> x : mergeBuckets xs' ys++-- | Override-merge oftwo indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+override i1@(PackageIndex m1) i2@(PackageIndex m2) =+  expensiveAssert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2)++-- | Inserts a single package into the index.+--+-- This is equivalent to (but slightly quicker than) using 'mappend' or+-- 'merge' with a singleton index.+--+insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg+insert pkg (PackageIndex index) = mkPackageIndex $+  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index+  where+    pkgid = packageId pkg+    insertNoDup []                = [pkg]+    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+      LT -> pkg  : pkgs+      EQ -> pkg  : pkgs'+      GT -> pkg' : insertNoDup pkgs'++-- | Internal delete helper.+--+delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg+       -> PackageIndex pkg+delete name p (PackageIndex index) = mkPackageIndex $+  Map.update filterBucket name index+  where+    filterBucket = deleteEmptyBucket+                 . filter (not . p)+    deleteEmptyBucket []        = Nothing+    deleteEmptyBucket remaining = Just remaining++-- | Removes a single package from the index.+--+deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg+                -> PackageIndex pkg+deletePackageId pkgid =+  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)++-- | Removes all packages with this (case-sensitive) name from the index.+--+deletePackageName :: Package pkg => PackageName -> PackageIndex pkg+                  -> PackageIndex pkg+deletePackageName name =+  delete name (\pkg -> packageName pkg == name)++-- | Removes all packages satisfying this dependency from the index.+deleteDependency :: Package pkg+                 => PackageName -> VersionRange -> PackageIndex pkg+                 -> PackageIndex pkg+deleteDependency name verstionRange =+  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)++--+-- * Bulk queries+--++-- | Get all the packages from the index.+--+allPackages :: PackageIndex pkg -> [pkg]+allPackages (PackageIndex m) = concat (Map.elems m)++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: PackageIndex pkg -> [[pkg]]+allPackagesByName (PackageIndex m) = Map.elems m++--+-- * Lookups+--++elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool+elemByPackageId index = isJust . lookupPackageId index++elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool+elemByPackageName index = not . null . lookupPackageName index+++-- | Does a lookup by package id (name & version).+--+-- Since multiple package DBs mask each other case-sensitively by package name,+-- then we get back at most one package.+--+lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier+                -> Maybe pkg+lookupPackageId index pkgid =+  case [ pkg | pkg <- lookup index (packageName pkgid)+             , packageId pkg == pkgid ] of+    []    -> Nothing+    [pkg] -> Just pkg+    _     -> internalError "lookupPackageIdentifier"++-- | Does a case-sensitive search by package name.+--+lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookupPackageName index name =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name ]++-- | Does a case-sensitive search by package name and a range of versions.+--+-- We get back any number of versions of the specified package name, all+-- satisfying the version range constraint.+--+lookupDependency :: Package pkg+                 => PackageIndex pkg+                 -> PackageName -> VersionRange+                 -> [pkg]+lookupDependency index name versionRange =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name+        , packageVersion pkg `withinRange` versionRange ]++--+-- * Case insensitive name lookups+--++-- | Does a case-insensitive search by package 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-insensitively but one matches exactly then it is also+-- unambiguous.+--+-- 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.+--+searchByName :: PackageIndex pkg+             -> String -> [(PackageName, [pkg])]+searchByName (PackageIndex m) name =+    [ pkgs+    | pkgs@(pname,_) <- Map.toList m+    , lowercase (unPackageName pname) == lname ]+  where+    lname = lowercase name++data SearchResult a = None | Unambiguous a | Ambiguous [a]++-- | Does a case-insensitive substring search by package name.+--+-- That is, all packages that contain the given string in their name.+--+searchByNameSubstring :: PackageIndex pkg+                      -> String -> [(PackageName, [pkg])]+searchByNameSubstring index searchterm =+    searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)+  where lsearchterm = lowercase searchterm++searchWithPredicate :: PackageIndex pkg+                    -> (String -> Bool) -> [(PackageName, [pkg])]+searchWithPredicate (PackageIndex m) predicate =+    [ pkgs+    | pkgs@(pname, _) <- Map.toList m+    , predicate (unPackageName pname)+    ]
+ cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs view
@@ -0,0 +1,102 @@+module Distribution.Solver.Types.PackagePath+    ( PackagePath(..)+    , Namespace(..)+    , Qualifier(..)+    , dispQualifier+    , Qualified(..)+    , QPN+    , dispQPN+    , showQPN+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()+import Distribution.Package (PackageName)+import Distribution.Pretty (pretty, flatStyle)+import qualified Text.PrettyPrint as Disp++-- | A package path consists of a namespace and a package path inside that+-- namespace.+data PackagePath = PackagePath Namespace Qualifier+  deriving (Eq, Ord, Show)++-- | Top-level namespace+--+-- Package choices in different namespaces are considered completely independent+-- by the solver.+data Namespace =+    -- | The default namespace+    DefaultNamespace++    -- | A namespace for a specific build target+  | Independent PackageName+  deriving (Eq, Ord, Show)++-- | Pretty-prints a namespace. The result is either empty or+-- ends in a period, so it can be prepended onto a qualifier.+dispNamespace :: Namespace -> Disp.Doc+dispNamespace DefaultNamespace = Disp.empty+dispNamespace (Independent i) = pretty i <<>> Disp.text "."++-- | Qualifier of a package within a namespace (see 'PackagePath')+data Qualifier =+    -- | Top-level dependency in this namespace+    QualToplevel++    -- | Any dependency on base is considered independent+    --+    -- This makes it possible to have base shims.+  | QualBase PackageName++    -- | Setup dependency+    --+    -- By rights setup dependencies ought to be nestable; after all, the setup+    -- dependencies of a package might themselves have setup dependencies, which+    -- are independent from everything else. However, this very quickly leads to+    -- infinite search trees in the solver. Therefore we limit ourselves to+    -- a single qualifier (within a given namespace).+  | QualSetup PackageName++    -- | If we depend on an executable from a package (via+    -- @build-tools@), we should solve for the dependencies of that+    -- package separately (since we're not going to actually try to+    -- link it.)  We qualify for EACH package separately; e.g.,+    -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on+    -- @pn2@ from package @pn1@.  (If we tracked only @pn1@, that+    -- would require a consistent dependency resolution for all+    -- of the depended upon executables from a package; if we+    -- tracked only @pn2@, that would require us to pick only one+    -- version of an executable over the entire install plan.)+  | QualExe PackageName PackageName+  deriving (Eq, Ord, Show)++-- | Pretty-prints a qualifier. The result is either empty or+-- ends in a period, so it can be prepended onto a package name.+--+-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is+-- there to make sure different dependencies on base are all independent.+-- So we want to print something like @"A.base"@, where the @"A."@ part+-- is the qualifier and @"base"@ is the actual dependency (which, for the+-- 'Base' qualifier, will always be @base@).+dispQualifier :: Qualifier -> Disp.Doc+dispQualifier QualToplevel = Disp.empty+dispQualifier (QualSetup pn)  = pretty pn <<>> Disp.text ":setup."+dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>>+                                 pretty pn2 <<>> Disp.text ":exe."+dispQualifier (QualBase pn)  = pretty pn <<>> Disp.text "."++-- | A qualified entity. Pairs a package path with the entity.+data Qualified a = Q PackagePath a+  deriving (Eq, Ord, Show)++-- | Qualified package name.+type QPN = Qualified PackageName++-- | Pretty-prints a qualified package name.+dispQPN :: QPN -> Disp.Doc+dispQPN (Q (PackagePath ns qual) pn) =+  dispNamespace ns <<>> dispQualifier qual <<>> pretty pn++-- | String representation of a qualified package name.+showQPN :: QPN -> String+showQPN = Disp.renderStyle flatStyle . dispQPN
+ cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs view
@@ -0,0 +1,22 @@+module Distribution.Solver.Types.PackagePreferences+    ( PackagePreferences(..)+    ) where++import Distribution.Solver.Types.InstalledPreference+import Distribution.Solver.Types.OptionalStanza+import Distribution.Version (VersionRange)++-- | Per-package preferences on the version. It is a soft constraint that the+-- 'DependencyResolver' should try to respect where possible. It consists of+-- an 'InstalledPreference' which says if we prefer versions of packages+-- that are already installed. It also has (possibly multiple)+-- 'PackageVersionPreference's which are suggested constraints on the version+-- number. The resolver should try to use package versions that satisfy+-- the maximum number of the suggested version constraints.+--+-- It is not specified if preferences on some packages are more important than+-- others.+--+data PackagePreferences = PackagePreferences [VersionRange]+                                             InstalledPreference+                                             [OptionalStanza]
+ cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Solver.Types.PkgConfigDb+-- Copyright   :  (c) Iñaki García Etxebarria 2016+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Read the list of packages available to pkg-config.+-----------------------------------------------------------------------------+module Distribution.Solver.Types.PkgConfigDb+    ( PkgConfigDb+    , readPkgConfigDb+    , pkgConfigDbFromList+    , pkgConfigPkgIsPresent+    , pkgConfigDbPkgVersion+    , getPkgConfigDbDirs+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import           Control.Exception (handle)+import qualified Data.Map          as M+import           System.FilePath   (splitSearchPath)++import Distribution.Compat.Environment          (lookupEnv)+import Distribution.Package                     (PkgconfigName, mkPkgconfigName)+import Distribution.Parsec+import Distribution.Simple.Program+       (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram)+import Distribution.Simple.Utils                (info)+import Distribution.Types.PkgconfigVersion+import Distribution.Types.PkgconfigVersionRange+import Distribution.Verbosity                   (Verbosity)++-- | The list of packages installed in the system visible to+-- @pkg-config@. This is an opaque datatype, to be constructed with+-- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`.+data PkgConfigDb =  PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion))+                 -- ^ If an entry is `Nothing`, this means that the+                 -- package seems to be present, but we don't know the+                 -- exact version (because parsing of the version+                 -- number failed).+                 | NoPkgConfigDb+                 -- ^ For when we could not run pkg-config successfully.+     deriving (Show, Generic, Typeable)++instance Binary PkgConfigDb+instance Structured PkgConfigDb++-- | Query pkg-config for the list of installed packages, together+-- with their versions. Return a `PkgConfigDb` encapsulating this+-- information.+readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb+readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do+    mpkgConfig <- needProgram verbosity pkgConfigProgram progdb+    case mpkgConfig of+      Nothing             -> noPkgConfig "Cannot find pkg-config program"+      Just (pkgConfig, _) -> do+        pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]+        -- The output of @pkg-config --list-all@ also includes a description+        -- for each package, which we do not need.+        let pkgNames = map (takeWhile (not . isSpace)) pkgList+        pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig+                                   ("--modversion" : pkgNames)+        (return . pkgConfigDbFromList . zip pkgNames) pkgVersions+  where+    -- For when pkg-config invocation fails (possibly because of a+    -- too long command line).+    noPkgConfig extra = do+        info verbosity ("Failed to query pkg-config, Cabal will continue"+                        ++ " without solving for pkg-config constraints: "+                        ++ extra)+        return NoPkgConfigDb++    ioErrorHandler :: IOException -> IO PkgConfigDb+    ioErrorHandler e = noPkgConfig (show e)++-- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs.+pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb+pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs+    where+      convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion)+      convert (n,vs) = (mkPkgconfigName n, simpleParsec vs)++-- | Check whether a given package range is satisfiable in the given+-- @pkg-config@ database.+pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool+pkgConfigPkgIsPresent (PkgConfigDb db) pn vr =+    case M.lookup pn db of+      Nothing       -> False    -- Package not present in the DB.+      Just Nothing  -> True     -- Package present, but version unknown.+      Just (Just v) -> withinPkgconfigVersionRange v vr+-- If we could not read the pkg-config database successfully we allow+-- the check to succeed. The plan found by the solver may fail to be+-- executed later on, but we have no grounds for rejecting the plan at+-- this stage.+pkgConfigPkgIsPresent NoPkgConfigDb _ _ = True+++-- | Query the version of a package in the @pkg-config@ database.+-- @Nothing@ indicates the package is not in the database, while+-- @Just Nothing@ indicates that the package is in the database,+-- but its version is not known.+pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion)+pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db+-- NB: Since the solver allows solving to succeed if there is+-- NoPkgConfigDb, we should report that we *guess* that there+-- is a matching pkg-config configuration, but that we just+-- don't know about it.+pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing+++-- | Query pkg-config for the locations of pkg-config's package files. Use this+-- to monitor for changes in the pkg-config DB.+--+getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath]+getPkgConfigDbDirs verbosity progdb =+    (++) <$> getEnvPath <*> getDefPath+ where+    -- According to @man pkg-config@:+    --+    -- PKG_CONFIG_PATH+    -- A  colon-separated  (on Windows, semicolon-separated) list of directories+    -- to search for .pc files.  The default directory will always be searched+    -- after searching the path+    --+    getEnvPath = maybe [] parseSearchPath+             <$> lookupEnv "PKG_CONFIG_PATH"++    -- Again according to @man pkg-config@:+    --+    -- pkg-config can be used to query itself for the default search path,+    -- version number and other information, for instance using:+    --+    -- > pkg-config --variable pc_path pkg-config+    --+    getDefPath = handle ioErrorHandler $ do+      mpkgConfig <- needProgram verbosity pkgConfigProgram progdb+      case mpkgConfig of+        Nothing -> return []+        Just (pkgConfig, _) -> parseSearchPath <$>+          getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"]++    parseSearchPath str =+      case lines str of+        [p] | not (null p) -> splitSearchPath p+        _                  -> []++    ioErrorHandler :: IOException -> IO [FilePath]+    ioErrorHandler _e = return []
+ cabal-install-solver/src/Distribution/Solver/Types/Progress.hs view
@@ -0,0 +1,49 @@+module Distribution.Solver.Types.Progress+    ( Progress(..)+    , foldProgress+    ) where++import Prelude ()+import Distribution.Solver.Compat.Prelude hiding (fail)++-- | A type to represent the unfolding of an expensive long running+-- calculation that may fail. We may get intermediate steps before the final+-- 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+                             | Done done++-- This Functor instance works around a bug in GHC 7.6.3.+-- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637.+-- The derived functor instance caused a space leak in the solver.+instance Functor (Progress step fail) where+  fmap f (Step s p) = Step s (fmap f p)+  fmap _ (Fail x)   = Fail x+  fmap f (Done r)   = Done (f r)++-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two+-- base cases, one for a final result and one for failure.+--+-- Eg to convert into a simple 'Either' result use:+--+-- > foldProgress (flip const) Left Right+--+foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)+             -> Progress step fail done -> a+foldProgress step fail done = fold+  where fold (Step s p) = step s (fold p)+        fold (Fail f)   = fail f+        fold (Done r)   = done r++instance Monad (Progress step fail) where+  return   = pure+  p >>= f  = foldProgress Step Fail f p++instance Applicative (Progress step fail) where+  pure a  = Done a+  p <*> x = foldProgress Step Fail (flip fmap x) p++instance Monoid fail => Alternative (Progress step fail) where+  empty   = Fail mempty+  p <|> q = foldProgress Step (const q) Done p
+ cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.ResolverPackage+    ( ResolverPackage(..)+    , resolverPackageLibDeps+    , resolverPackageExeDeps+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Solver.Types.InstSolverPackage+import Distribution.Solver.Types.SolverId+import Distribution.Solver.Types.SolverPackage+import qualified Distribution.Solver.Types.ComponentDeps as CD++import Distribution.Compat.Graph (IsNode(..))+import Distribution.Package (Package(..), HasUnitId(..))+import Distribution.Simple.Utils (ordNub)++-- | The dependency resolver picks either pre-existing installed packages+-- or it picks source packages along with package configuration.+--+-- This is like the 'InstallPlan.PlanPackage' but with fewer cases.+--+data ResolverPackage loc = PreExisting InstSolverPackage+                         | Configured  (SolverPackage loc)+  deriving (Eq, Show, Generic)++instance Binary loc => Binary (ResolverPackage loc)+instance Structured loc => Structured (ResolverPackage loc)++instance Package (ResolverPackage loc) where+  packageId (PreExisting ipkg)     = packageId ipkg+  packageId (Configured  spkg)     = packageId spkg++resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]+resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg+resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg++resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId]+resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg+resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg++instance IsNode (ResolverPackage loc) where+  type Key (ResolverPackage loc) = SolverId+  nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg)+  nodeKey (Configured spkg) = PlannedId (packageId spkg)+  -- Use dependencies for ALL components+  nodeNeighbors pkg =+    ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) +++             CD.flatDeps (resolverPackageExeDeps pkg)
+ cabal-install-solver/src/Distribution/Solver/Types/Settings.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Solver.Types.Settings+    ( ReorderGoals(..)+    , IndependentGoals(..)+    , MinimizeConflictSet(..)+    , AvoidReinstalls(..)+    , ShadowPkgs(..)+    , StrongFlags(..)+    , AllowBootLibInstalls(..)+    , OnlyConstrained(..)+    , EnableBackjumping(..)+    , CountConflicts(..)+    , FineGrainedConflicts(..)+    , SolveExecutables(..)+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Simple.Setup ( BooleanFlag(..) )+import Distribution.Pretty ( Pretty(pretty) )+import Distribution.Parsec ( Parsec(parsec) )++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint as PP++newtype ReorderGoals = ReorderGoals Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype CountConflicts = CountConflicts Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype FineGrainedConflicts = FineGrainedConflicts Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype MinimizeConflictSet = MinimizeConflictSet Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype IndependentGoals = IndependentGoals Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype AvoidReinstalls = AvoidReinstalls Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype ShadowPkgs = ShadowPkgs Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype StrongFlags = StrongFlags Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype AllowBootLibInstalls = AllowBootLibInstalls Bool+  deriving (BooleanFlag, Eq, Generic, Show)++-- | Should we consider all packages we know about, or only those that+-- have constraints explicitly placed on them or which are goals?+data OnlyConstrained+  = OnlyConstrainedNone+  | OnlyConstrainedAll+  deriving (Eq, Generic, Show)++newtype EnableBackjumping = EnableBackjumping Bool+  deriving (BooleanFlag, Eq, Generic, Show)++newtype SolveExecutables = SolveExecutables Bool+  deriving (BooleanFlag, Eq, Generic, Show)++instance Binary ReorderGoals+instance Binary CountConflicts+instance Binary FineGrainedConflicts+instance Binary IndependentGoals+instance Binary MinimizeConflictSet+instance Binary AvoidReinstalls+instance Binary ShadowPkgs+instance Binary StrongFlags+instance Binary AllowBootLibInstalls+instance Binary OnlyConstrained+instance Binary SolveExecutables++instance Structured ReorderGoals+instance Structured CountConflicts+instance Structured FineGrainedConflicts+instance Structured IndependentGoals+instance Structured MinimizeConflictSet+instance Structured AvoidReinstalls+instance Structured ShadowPkgs+instance Structured StrongFlags+instance Structured AllowBootLibInstalls+instance Structured OnlyConstrained+instance Structured SolveExecutables++instance Pretty OnlyConstrained where+  pretty OnlyConstrainedAll  = PP.text "all"+  pretty OnlyConstrainedNone = PP.text "none"++instance Parsec OnlyConstrained where+  parsec = P.choice+    [ P.string "all"  >> return OnlyConstrainedAll+    , P.string "none" >> return OnlyConstrainedNone+    ]+
+ cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.SolverId+    ( SolverId(..)+    )++where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Package (PackageId, Package(..), UnitId)++-- | The solver can produce references to existing packages or+-- packages we plan to install.  Unlike 'ConfiguredId' we don't+-- yet know the 'UnitId' for planned packages, because it's+-- not the solver's job to compute them.+--+data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId }+              | PlannedId     { solverSrcId :: PackageId }+  deriving (Eq, Ord, Generic)++instance Binary SolverId+instance Structured SolverId++instance Show SolverId where+    show = show . solverSrcId++instance Package SolverId where+  packageId = solverSrcId
+ cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Solver.Types.SolverPackage+    ( SolverPackage(..)+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Package ( Package(..) )+import Distribution.PackageDescription ( FlagAssignment )+import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.SolverId+import Distribution.Solver.Types.SourcePackage++-- | A 'SolverPackage' is a package specified by the dependency solver.+-- It will get elaborated into a 'ConfiguredPackage' or even an+-- 'ElaboratedConfiguredPackage'.+--+-- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc',+-- but for symmetry we have the parameter.  (Maybe it can be removed.)+--+data SolverPackage loc = SolverPackage {+        solverPkgSource  :: SourcePackage loc,+        solverPkgFlags   :: FlagAssignment,+        solverPkgStanzas :: OptionalStanzaSet,+        solverPkgLibDeps :: ComponentDeps [SolverId],+        solverPkgExeDeps :: ComponentDeps [SolverId]+    }+  deriving (Eq, Show, Generic)++instance Binary loc => Binary (SolverPackage loc)+instance Structured loc => Structured (SolverPackage loc)++instance Package (SolverPackage loc) where+  packageId = packageId . solverPkgSource
+ cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Distribution.Solver.Types.SourcePackage+    ( PackageDescriptionOverride+    , SourcePackage(..)+    ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Package+         ( PackageId, Package(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(..) )++import Data.ByteString.Lazy (ByteString)++-- | A package description along with the location of the package sources.+--+data SourcePackage loc = SourcePackage+  { srcpkgPackageId     :: PackageId+  , srcpkgDescription   :: GenericPackageDescription+    -- ^ Note, this field is lazy, e.g. when reading in hackage index+    --   we parse only what we need, not whole index.+  , srcpkgSource        :: loc+  , srcpkgDescrOverride :: PackageDescriptionOverride+  }+  deriving (Eq, Show, Generic, Typeable)++instance Binary loc => Binary (SourcePackage loc)+instance Structured loc => Structured (SourcePackage loc)++instance Package (SourcePackage a) where packageId = srcpkgPackageId++-- | We sometimes need to override the .cabal file in the tarball with+-- the newer one from the package index.+type PackageDescriptionOverride = Maybe ByteString
+ cabal-install-solver/src/Distribution/Solver/Types/Variable.hs view
@@ -0,0 +1,15 @@+module Distribution.Solver.Types.Variable where++import Prelude (Eq, Show)++import Distribution.Solver.Types.OptionalStanza++import Distribution.PackageDescription (FlagName)++-- | Variables used by the dependency solver. This type is similar to the+-- internal 'Var' type.+data Variable qpn =+    PackageVar qpn+  | FlagVar qpn FlagName+  | StanzaVar qpn OptionalStanza+  deriving (Eq, Show)
cabal-install.cabal view
@@ -4,7 +4,7 @@ -- To update this file, edit 'cabal-install.cabal.pp' and run -- 'make cabal-install-prod' in the project's root folder. Name:               cabal-install-Version:            3.4.1.0+Version:            3.6.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -22,82 +22,6 @@ Extra-Source-Files:   README.md bash-completion/cabal changelog -  -- Generated with 'make gen-extra-source-files'-  -- Do NOT edit this section manually; instead, run the script.-  -- BEGIN gen-extra-source-files-  tests/IntegrationTests2/build/keep-going/cabal.project-  tests/IntegrationTests2/build/keep-going/p/P.hs-  tests/IntegrationTests2/build/keep-going/p/p.cabal-  tests/IntegrationTests2/build/keep-going/q/Q.hs-  tests/IntegrationTests2/build/keep-going/q/q.cabal-  tests/IntegrationTests2/build/local-tarball/cabal.project-  tests/IntegrationTests2/build/local-tarball/q/Q.hs-  tests/IntegrationTests2/build/local-tarball/q/q.cabal-  tests/IntegrationTests2/build/setup-custom1/A.hs-  tests/IntegrationTests2/build/setup-custom1/Setup.hs-  tests/IntegrationTests2/build/setup-custom1/a.cabal-  tests/IntegrationTests2/build/setup-custom2/A.hs-  tests/IntegrationTests2/build/setup-custom2/Setup.hs-  tests/IntegrationTests2/build/setup-custom2/a.cabal-  tests/IntegrationTests2/build/setup-simple/A.hs-  tests/IntegrationTests2/build/setup-simple/Setup.hs-  tests/IntegrationTests2/build/setup-simple/a.cabal-  tests/IntegrationTests2/exception/bad-config/cabal.project-  tests/IntegrationTests2/exception/build/Main.hs-  tests/IntegrationTests2/exception/build/a.cabal-  tests/IntegrationTests2/exception/configure/a.cabal-  tests/IntegrationTests2/exception/no-pkg/empty.in-  tests/IntegrationTests2/exception/no-pkg2/cabal.project-  tests/IntegrationTests2/regression/3324/cabal.project-  tests/IntegrationTests2/regression/3324/p/P.hs-  tests/IntegrationTests2/regression/3324/p/p.cabal-  tests/IntegrationTests2/regression/3324/q/Q.hs-  tests/IntegrationTests2/regression/3324/q/q.cabal-  tests/IntegrationTests2/targets/all-disabled/cabal.project-  tests/IntegrationTests2/targets/all-disabled/p.cabal-  tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project-  tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal-  tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal-  tests/IntegrationTests2/targets/complex/cabal.project-  tests/IntegrationTests2/targets/complex/q/Q.hs-  tests/IntegrationTests2/targets/complex/q/q.cabal-  tests/IntegrationTests2/targets/empty-pkg/cabal.project-  tests/IntegrationTests2/targets/empty-pkg/p.cabal-  tests/IntegrationTests2/targets/empty/cabal.project-  tests/IntegrationTests2/targets/empty/foo.hs-  tests/IntegrationTests2/targets/exes-disabled/cabal.project-  tests/IntegrationTests2/targets/exes-disabled/p/p.cabal-  tests/IntegrationTests2/targets/exes-disabled/q/q.cabal-  tests/IntegrationTests2/targets/lib-only/p.cabal-  tests/IntegrationTests2/targets/libs-disabled/cabal.project-  tests/IntegrationTests2/targets/libs-disabled/p/p.cabal-  tests/IntegrationTests2/targets/libs-disabled/q/q.cabal-  tests/IntegrationTests2/targets/multiple-exes/cabal.project-  tests/IntegrationTests2/targets/multiple-exes/p.cabal-  tests/IntegrationTests2/targets/multiple-libs/cabal.project-  tests/IntegrationTests2/targets/multiple-libs/p/p.cabal-  tests/IntegrationTests2/targets/multiple-libs/q/q.cabal-  tests/IntegrationTests2/targets/multiple-tests/cabal.project-  tests/IntegrationTests2/targets/multiple-tests/p.cabal-  tests/IntegrationTests2/targets/simple/P.hs-  tests/IntegrationTests2/targets/simple/app/Main.hs-  tests/IntegrationTests2/targets/simple/cabal.project-  tests/IntegrationTests2/targets/simple/p.cabal-  tests/IntegrationTests2/targets/simple/q/Q.hs-  tests/IntegrationTests2/targets/simple/q/QQ.hs-  tests/IntegrationTests2/targets/simple/q/q.cabal-  tests/IntegrationTests2/targets/test-only/p.cabal-  tests/IntegrationTests2/targets/tests-disabled/cabal.project-  tests/IntegrationTests2/targets/tests-disabled/p.cabal-  tests/IntegrationTests2/targets/tests-disabled/q/q.cabal-  tests/IntegrationTests2/targets/variety/cabal.project-  tests/IntegrationTests2/targets/variety/p.cabal-  -- END gen-extra-source-files--  -- Additional manual extra-source-files:-  tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz-- source-repository head   type:     git   location: https://github.com/haskell/cabal/@@ -132,7 +56,7 @@     main-is:        Main.hs     hs-source-dirs: main     default-language: Haskell2010-    ghc-options:    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns+    ghc-options:    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates     if impl(ghc >= 8.0)         ghc-options: -Wcompat                      -Wnoncanonical-monad-instances@@ -148,7 +72,7 @@     -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a     if os(aix)         extra-libraries: bsd-    hs-source-dirs: .+    hs-source-dirs: src     other-modules:         -- this modules are moved from Cabal         -- they are needed for as long until cabal-install moves to parsec parser@@ -192,7 +116,6 @@         Distribution.Client.Dependency         Distribution.Client.Dependency.Types         Distribution.Client.DistDirLayout-        Distribution.Client.Exec         Distribution.Client.Fetch         Distribution.Client.FetchUtils         Distribution.Client.FileMonitor@@ -274,15 +197,20 @@         Distribution.Client.Types.SourcePackageDb         Distribution.Client.Types.SourceRepo         Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy-        Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils-        Distribution.Client.Utils.Assertion         Distribution.Client.Utils.Json         Distribution.Client.Utils.Parsec         Distribution.Client.VCS         Distribution.Client.Win32SelfUpgrade         Distribution.Client.World++    hs-source-dirs: cabal-install-solver/src-assertion+    other-modules:+        Distribution.Client.Utils.Assertion++    hs-source-dirs: cabal-install-solver/src+    other-modules:         Distribution.Solver.Compat.Prelude         Distribution.Solver.Modular         Distribution.Solver.Modular.Assignment@@ -331,6 +259,8 @@         Distribution.Solver.Types.SolverPackage         Distribution.Solver.Types.SourcePackage         Distribution.Solver.Types.Variable++    other-modules:         Paths_cabal_install      build-depends:@@ -339,8 +269,8 @@         base       >= 4.8      && < 4.15,         base16-bytestring >= 0.1.1 && < 1.1.0.0,         binary     >= 0.7.3    && < 0.9,-        bytestring >= 0.10.6.0 && < 0.11,-        Cabal      == 3.4.1.*,+        bytestring >= 0.10.6.0 && < 0.12,+        Cabal      == 3.6.*,         containers >= 0.5.6.2  && < 0.7,         cryptohash-sha256 >= 0.11 && < 0.12,         deepseq    >= 1.4.1.1  && < 1.5,
changelog view
@@ -1,7 +1,6 @@ -*-change-log-*---3.4.1.0 Emily Pillmore <emilypi@cohomolo.gy> October 2021-	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.1.0.md+3.6.0.0 Emily Pillmore <emilypi@cohomolo.gy> August 2021+	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.0.0.md  3.4.0.0 Oleg Grenrus <oleg.grenrus@iki.fi> February 2021 	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.4.0.0.md
main/Main.hs view
@@ -32,7 +32,6 @@          , GetFlags(..), getCommand, unpackCommand          , checkCommand          , formatCommand-         , UpdateFlags(..), updateCommand          , ListFlags(..), listCommand, listNeedsCompiler          , InfoFlags(..), infoCommand          , UploadFlags(..), uploadCommand@@ -40,19 +39,16 @@          , runCommand          , InitFlags(initVerbosity, initHcPath), initCommand          , ActAsSetupFlags(..), actAsSetupCommand-         , ExecFlags(..), execCommand          , UserConfigFlags(..), userConfigCommand          , reportCommand          , manpageCommand          , haddockCommand          , cleanCommand-         , doctestCommand          , copyCommand          , registerCommand          ) import Distribution.Simple.Setup          ( HaddockTarget(..)-         , DoctestFlags(..)          , HaddockFlags(..), defaultHaddockFlags          , HscolourFlags(..), hscolourCommand          , ReplFlags(..)@@ -65,7 +61,7 @@          )  import Prelude ()-import Distribution.Solver.Compat.Prelude hiding (get)+import Distribution.Client.Compat.Prelude hiding (get)  import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )@@ -95,8 +91,6 @@  import Distribution.Client.Install            (install) import Distribution.Client.Configure          (configure, writeConfigFlags)-import Distribution.Client.Update             (update)-import Distribution.Client.Exec               (exec) import Distribution.Client.Fetch              (fetch) import Distribution.Client.Freeze             (freeze) import Distribution.Client.GenBounds          (genBounds)@@ -112,8 +106,7 @@                                               ) import Distribution.Client.Sandbox            (loadConfigOrSandboxConfig                                               ,findSavedDistPref-                                              ,updateInstallDirs-                                              ,getPersistOrConfigCompiler)+                                              ,updateInstallDirs) import Distribution.Client.Tar                (createTarGzFile) import Distribution.Client.Types.Credentials  (Password (..)) import Distribution.Client.Init               (initCabal)@@ -157,7 +150,7 @@ import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )+         ( normal ) import Distribution.Version          ( Version, mkVersion, orLaterVersion ) import qualified Paths_cabal_install (version)@@ -270,7 +263,6 @@       , newCmd  CmdSdist.sdistCommand         CmdSdist.sdistAction        , legacyCmd configureExCommand configureAction-      , legacyCmd updateCommand updateAction       , legacyCmd buildCommand buildAction       , legacyCmd replCommand replAction       , legacyCmd freezeCommand freezeAction@@ -279,9 +271,7 @@       , legacyCmd runCommand runAction       , legacyCmd testCommand testAction       , legacyCmd benchmarkCommand benchmarkAction-      , legacyCmd execCommand execAction       , legacyCmd cleanCommand cleanAction-      , legacyCmd doctestCommand doctestAction       , legacyWrapperCmd copyCommand copyVerbosity copyDistPref       , legacyWrapperCmd registerCommand regVerbosity regDistPref       , legacyCmd reconfigureCommand reconfigureAction@@ -678,13 +668,6 @@       createTarGzFile dest docDir name       notice verbosity $ "Documentation tarball created: " ++ dest -doctestAction :: DoctestFlags -> [String] -> Action-doctestAction doctestFlags extraArgs _globalFlags = do-  let verbosity = fromFlag (doctestVerbosity doctestFlags)--  setupWrapper verbosity defaultSetupScriptOptions Nothing-    doctestCommand (const doctestFlags) (const extraArgs)- cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do   load <- try (loadConfigOrSandboxConfig verbosity globalFlags)@@ -746,16 +729,6 @@        infoFlags        targets -updateAction :: UpdateFlags -> [String] -> Action-updateAction updateFlags extraArgs globalFlags = do-  let verbosity = fromFlag (updateVerbosity updateFlags)-  unless (null extraArgs) $-    die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs-  config <- loadConfigOrSandboxConfig verbosity globalFlags-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  withRepoContext verbosity globalFlags' $ \repoContext ->-    update verbosity updateFlags repoContext- fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do   let verbosity = fromFlag (fetchVerbosity fetchFlags)@@ -964,16 +937,6 @@             comp             progdb             initFlags'--execAction :: ExecFlags -> [String] -> Action-execAction execFlags extraArgs globalFlags = do-  let verbosity = fromFlag (execVerbosity execFlags)-  config <- loadConfigOrSandboxConfig verbosity globalFlags-  distPref <- findSavedDistPref config (execDistPref execFlags)-  let configFlags = savedConfigureFlags config-      configFlags' = configFlags { configDistPref = Flag distPref }-  (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags'-  exec verbosity comp platform progdb extraArgs  userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do
+ src/Distribution/Client/BuildReports/Anonymous.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Anonymous (+    BuildReport(..),+    InstallOutcome(..),+    Outcome(..),++    -- * Constructing and writing reports+    newBuildReport,++    -- * parsing and pretty printing+    parseBuildReport,+    parseBuildReportList,+    showBuildReport,+--    showList,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.CabalSpecVersion+import Distribution.Client.BuildReports.Types+import Distribution.Client.Utils              (cabalInstallVersion)+import Distribution.Compiler                  (CompilerId (..))+import Distribution.FieldGrammar+import Distribution.Fields                    (readFields, showFields)+import Distribution.Fields.ParseResult        (ParseResult, parseFatalFailure, runParseResult)+import Distribution.Package                   (PackageIdentifier (..), mkPackageName)+import Distribution.PackageDescription        (FlagAssignment)+import Distribution.Parsec                    (PError (..), zeroPos)+import Distribution.System                    (Arch, OS)++import qualified Distribution.Client.BuildReports.Lens as L+import qualified Distribution.Client.Types             as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))++import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BS8+++-------------------------------------------------------------------------------+-- New+-------------------------------------------------------------------------------++newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment+    -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport+newBuildReport os' arch' comp pkgid flags deps result =+  BuildReport {+    package               = pkgid,+    os                    = os',+    arch                  = arch',+    compiler              = comp,+    client                = cabalInstallID,+    flagAssignment        = flags,+    dependencies          = deps,+    installOutcome        = convertInstallOutcome,+--    cabalVersion          = undefined+    docsOutcome           = convertDocsOutcome,+    testsOutcome          = convertTestsOutcome+  }+  where+    convertInstallOutcome = case result of+      Left  BR.PlanningFailed      -> PlanningFailed+      Left  (BR.DependentFailed p) -> DependencyFailed p+      Left  (BR.DownloadFailed  _) -> DownloadFailed+      Left  (BR.UnpackFailed    _) -> UnpackFailed+      Left  (BR.ConfigureFailed _) -> ConfigureFailed+      Left  (BR.BuildFailed     _) -> BuildFailed+      Left  (BR.TestsFailed     _) -> TestsFailed+      Left  (BR.InstallFailed   _) -> InstallFailed+      Right (BR.BuildResult _ _ _) -> InstallOk+    convertDocsOutcome = case result of+      Left _                                      -> NotTried+      Right (BR.BuildResult BR.DocsNotTried _ _)  -> NotTried+      Right (BR.BuildResult BR.DocsFailed _ _)    -> Failed+      Right (BR.BuildResult BR.DocsOk _ _)        -> Ok+    convertTestsOutcome = case result of+      Left  (BR.TestsFailed _)                    -> Failed+      Left _                                      -> NotTried+      Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried+      Right (BR.BuildResult _ BR.TestsOk _)       -> Ok++cabalInstallID :: PackageIdentifier+cabalInstallID =+  PackageIdentifier (mkPackageName "cabal-install") cabalInstallVersion++-------------------------------------------------------------------------------+-- FieldGrammar+-------------------------------------------------------------------------------++fieldDescrs+    :: ( Applicative (g BuildReport), FieldGrammar c g+       , c (Identity Arch)+       , c (Identity CompilerId)+       , c (Identity FlagAssignment)+       , c (Identity InstallOutcome)+       , c (Identity OS)+       , c (Identity Outcome)+       , c (Identity PackageIdentifier)+       , c (List VCat (Identity PackageIdentifier) PackageIdentifier)+       )+    => g BuildReport BuildReport+fieldDescrs = BuildReport+    <$> uniqueField       "package"                           L.package+    <*> uniqueField       "os"                                L.os+    <*> uniqueField       "arch"                              L.arch+    <*> uniqueField       "compiler"                          L.compiler+    <*> uniqueField       "client"                            L.client+    <*> monoidalField     "flags"                             L.flagAssignment+    <*> monoidalFieldAla  "dependencies"       (alaList VCat) L.dependencies+    <*> uniqueField       "install-outcome"                   L.installOutcome+    <*> uniqueField       "docs-outcome"                      L.docsOutcome+    <*> uniqueField       "tests-outcome"                     L.testsOutcome++-- -----------------------------------------------------------------------------+-- Parsing++parseBuildReport :: BS.ByteString -> Either String BuildReport+parseBuildReport s = case snd $ runParseResult $ parseFields s of+  Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ]+  Right report -> Right report++parseFields :: BS.ByteString -> ParseResult BuildReport+parseFields input = do+  fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input+  case partitionFields fields of+    (fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs+    _otherwise    -> parseFatalFailure zeroPos "found sections in BuildReport"++parseBuildReportList :: BS.ByteString -> [BuildReport]+parseBuildReportList str =+  [ report | Right report <- map parseBuildReport (split str) ]++  where+    split :: BS.ByteString -> [BS.ByteString]+    split = filter (not . BS.null) . unfoldr chunk . BS8.lines+    chunk [] = Nothing+    chunk ls = case break BS.null ls of+                 (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)++-- -----------------------------------------------------------------------------+-- Pretty-printing++showBuildReport :: BuildReport -> String+showBuildReport = showFields (const []) . prettyFieldGrammar CabalSpecV2_4 fieldDescrs
+ src/Distribution/Client/BuildReports/Lens.hs view
@@ -0,0 +1,46 @@+module Distribution.Client.BuildReports.Lens (+    BuildReport,+    module Distribution.Client.BuildReports.Lens,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Compat.Lens+import Prelude ()++import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome)+import Distribution.Compiler                  (CompilerId)+import Distribution.System                    (Arch, OS)+import Distribution.Types.Flag                (FlagAssignment)+import Distribution.Types.PackageId           (PackageIdentifier)++import qualified Distribution.Client.BuildReports.Types as T++package :: Lens' BuildReport PackageIdentifier+package f s = fmap (\x -> s { T.package = x }) (f (T.package s))++os :: Lens' BuildReport OS+os f s = fmap (\x -> s { T.os = x }) (f (T.os s))++arch :: Lens' BuildReport Arch+arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s))++compiler :: Lens' BuildReport CompilerId+compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s))++client :: Lens' BuildReport PackageIdentifier+client f s = fmap (\x -> s { T.client = x }) (f (T.client s))++flagAssignment :: Lens' BuildReport FlagAssignment+flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s))++dependencies :: Lens' BuildReport [PackageIdentifier]+dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s))++installOutcome :: Lens' BuildReport InstallOutcome+installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s))++docsOutcome :: Lens' BuildReport Outcome+docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s))++testsOutcome :: Lens' BuildReport Outcome+testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s))
+ src/Distribution/Client/BuildReports/Storage.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Storage (++    -- * Storing and retrieving build reports+    storeAnonymous,+    storeLocal,+--    retrieve,++    -- * 'InstallPlan' support+    fromInstallPlan,+    fromPlanningFailure,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport)+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport++import Distribution.Client.Types+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( InstallPlan )++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.SourcePackage++import Distribution.Package+         ( PackageId, packageId )+import Distribution.PackageDescription+         ( FlagAssignment )+import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , initialPathTemplateEnv, substPathTemplate )+import Distribution.System+         ( Platform(Platform) )+import Distribution.Compiler+         ( CompilerId(..), CompilerInfo(..)  )+import Distribution.Simple.Utils+         ( equating )++import Data.List.NonEmpty+         ( groupBy )+import qualified Data.List as L+import System.FilePath+         ( (</>), takeDirectory )+import System.Directory+         ( createDirectoryIfMissing )++storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()+storeAnonymous reports = sequence_+  [ appendFile file (concatMap format reports')+  | (repo, reports') <- separate reports+  , let file = repoLocalDir repo </> "build-reports.log" ]+  --TODO: make this concurrency safe, either lock the report file or make sure+  -- the writes for each report are atomic (under 4k and flush at boundaries)++  where+    format r = '\n' : showBuildReport r ++ "\n"+    separate :: [(BuildReport, Maybe Repo)]+             -> [(Repo, [BuildReport])]+    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))+             . map (concatMap toList)+             . L.groupBy (equating (repoName' . head))+             . sortBy (comparing (repoName' . head))+             . groupBy (equating repoName')+             . onlyRemote++    repoName' (_,_,rrepo) = remoteRepoName rrepo++    onlyRemote :: [(BuildReport, Maybe Repo)]+               -> [(BuildReport, Repo, RemoteRepo)]+    onlyRemote rs =+      [ (report, repo, remoteRepo)+      | (report, Just repo) <- rs+      , Just remoteRepo     <- [maybeRepoRemote repo]+      ]++storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]+           -> Platform -> IO ()+storeLocal cinfo templates reports platform = sequence_+  [ do createDirectoryIfMissing True (takeDirectory file)+       appendFile file output+       --TODO: make this concurrency safe, either lock the report file or make+       --      sure the writes for each report are atomic+  | (file, reports') <- groupByFileName+                          [ (reportFileName template report, report)+                          | template <- templates+                          , (report, _repo) <- reports ]+  , let output = concatMap format reports'+  ]+  where+    format r = '\n' : showBuildReport r ++ "\n"++    reportFileName template report =+        fromPathTemplate (substPathTemplate env template)+      where env = initialPathTemplateEnv+                    (BuildReport.package  report)+                    -- TODO: In principle, we can support $pkgkey, but only+                    -- if the configure step succeeds.  So add a Maybe field+                    -- to the build report, and either use that or make up+                    -- a fake identifier if it's not available.+                    (error "storeLocal: package key not available")+                    cinfo+                    platform++    groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))+                    . L.groupBy (equating  fst)+                    . sortBy  (comparing fst)++-- ------------------------------------------------------------+-- * InstallPlan support+-- ------------------------------------------------------------++fromInstallPlan :: Platform -> CompilerId+                -> InstallPlan+                -> BuildOutcomes+                -> [(BuildReport, Maybe Repo)]+fromInstallPlan platform comp plan buildOutcomes =+     mapMaybe (\pkg -> fromPlanPackage+                         platform comp pkg+                         (InstallPlan.lookupBuildOutcome pkg buildOutcomes))+   . InstallPlan.toList+   $ plan++fromPlanPackage :: Platform -> CompilerId+                -> InstallPlan.PlanPackage+                -> Maybe BuildOutcome+                -> Maybe (BuildReport, Maybe Repo)+fromPlanPackage (Platform arch os) comp+                (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))+                (Just buildResult) =+      Just ( newBuildReport os arch comp+                             (packageId srcPkg) flags+                             (map packageId (CD.nonSetupDeps deps))+                             buildResult+           , extractRepo srcPkg)+  where+    extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ })+                  = Just repo+    extractRepo _ = Nothing++fromPlanPackage _ _ _ _ = Nothing+++fromPlanningFailure :: Platform -> CompilerId+    -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]+fromPlanningFailure (Platform arch os) comp pkgids flags =+  [ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing)+  | pkgid <- pkgids ]
+ src/Distribution/Client/BuildReports/Types.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE DeriveGeneric #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildReports.Types+-- Copyright   :  (c) Duncan Coutts 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Types related to build reporting+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Types (+    ReportLevel(..),+    BuildReport (..),+    InstallOutcome(..),+    Outcome(..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++import Distribution.Compiler           (CompilerId (..))+import Distribution.PackageDescription (FlagAssignment)+import Distribution.System             (Arch, OS)+import Distribution.Types.PackageId    (PackageIdentifier)++-------------------------------------------------------------------------------+-- ReportLevel+-------------------------------------------------------------------------------++data ReportLevel = NoReports | AnonymousReports | DetailedReports+  deriving (Eq, Ord, Enum, Bounded, Show, Generic)++instance Binary ReportLevel+instance Structured ReportLevel++instance Pretty ReportLevel where+  pretty NoReports        = Disp.text "none"+  pretty AnonymousReports = Disp.text "anonymous"+  pretty DetailedReports  = Disp.text "detailed"++instance Parsec ReportLevel where+  parsec = do+    name <- P.munch1 isAlpha+    case lowercase name of+      "none"       -> return NoReports+      "anonymous"  -> return AnonymousReports+      "detailed"   -> return DetailedReports+      _            -> P.unexpected $ "ReportLevel: " ++ name++lowercase :: String -> String+lowercase = map toLower++-------------------------------------------------------------------------------+-- BuildReport+-------------------------------------------------------------------------------++data BuildReport = BuildReport {+    -- | The package this build report is about+    package         :: PackageIdentifier,++    -- | The OS and Arch the package was built on+    os              :: OS,+    arch            :: Arch,++    -- | The Haskell compiler (and hopefully version) used+    compiler        :: CompilerId,++    -- | The uploading client, ie cabal-install-x.y.z+    client          :: PackageIdentifier,++    -- | Which configurations flags we used+    flagAssignment  :: FlagAssignment,++    -- | Which dependent packages we were using exactly+    dependencies    :: [PackageIdentifier],++    -- | Did installing work ok?+    installOutcome  :: InstallOutcome,++    --   Which version of the Cabal library was used to compile the Setup.hs+--    cabalVersion    :: Version,++    --   Which build tools we were using (with versions)+--    tools      :: [PackageIdentifier],++    -- | Configure outcome, did configure work ok?+    docsOutcome     :: Outcome,++    -- | Configure outcome, did configure work ok?+    testsOutcome    :: Outcome+  }+  deriving (Eq, Show, Generic)++++-------------------------------------------------------------------------------+-- InstallOutcome+-------------------------------------------------------------------------------++data InstallOutcome+   = PlanningFailed+   | DependencyFailed PackageIdentifier+   | DownloadFailed+   | UnpackFailed+   | SetupFailed+   | ConfigureFailed+   | BuildFailed+   | TestsFailed+   | InstallFailed+   | InstallOk+  deriving (Eq, Show, Generic)++instance Pretty InstallOutcome where+  pretty PlanningFailed  = Disp.text "PlanningFailed"+  pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid+  pretty DownloadFailed  = Disp.text "DownloadFailed"+  pretty UnpackFailed    = Disp.text "UnpackFailed"+  pretty SetupFailed     = Disp.text "SetupFailed"+  pretty ConfigureFailed = Disp.text "ConfigureFailed"+  pretty BuildFailed     = Disp.text "BuildFailed"+  pretty TestsFailed     = Disp.text "TestsFailed"+  pretty InstallFailed   = Disp.text "InstallFailed"+  pretty InstallOk       = Disp.text "InstallOk"++instance Parsec InstallOutcome where+  parsec = do+    name <- P.munch1 isAlpha+    case name of+      "PlanningFailed"   -> return PlanningFailed+      "DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec+      "DownloadFailed"   -> return DownloadFailed+      "UnpackFailed"     -> return UnpackFailed+      "SetupFailed"      -> return SetupFailed+      "ConfigureFailed"  -> return ConfigureFailed+      "BuildFailed"      -> return BuildFailed+      "TestsFailed"      -> return TestsFailed+      "InstallFailed"    -> return InstallFailed+      "InstallOk"        -> return InstallOk+      _                  -> P.unexpected $ "InstallOutcome: " ++ name++-------------------------------------------------------------------------------+-- Outcome+-------------------------------------------------------------------------------++data Outcome = NotTried | Failed | Ok+  deriving (Eq, Show, Enum, Bounded, Generic)++instance Pretty Outcome where+  pretty NotTried = Disp.text "NotTried"+  pretty Failed   = Disp.text "Failed"+  pretty Ok       = Disp.text "Ok"++instance Parsec Outcome where+  parsec = do+    name <- P.munch1 isAlpha+    case name of+      "NotTried" -> return NotTried+      "Failed"   -> return Failed+      "Ok"       -> return Ok+      _          -> P.unexpected $ "Outcome: " ++ name
+ src/Distribution/Client/BuildReports/Upload.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP, PatternGuards #-}+-- This is a quick hack for uploading build reports to Hackage.++module Distribution.Client.BuildReports.Upload+    ( BuildLog+    , BuildReportId+    , uploadReports+    ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++{-+import Network.Browser+         ( BrowserAction, request, setAllowRedirects )+import Network.HTTP+         ( Header(..), HeaderName(..)+         , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream)+-}+import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)++import System.FilePath.Posix+         ( (</>) )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport)+import Distribution.Simple.Utils (die')+import Distribution.Client.HttpUtils+import Distribution.Client.Setup+         ( RepoContext(..) )++type BuildReportId = URI+type BuildLog = String++uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()+uploadReports verbosity repoCtxt auth uri reports = do+  for_ reports $ \(report, mbBuildLog) -> do+     buildId <- postBuildReport verbosity repoCtxt auth uri report+     case mbBuildLog of+       Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog+       Nothing       -> return ()++postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId+postBuildReport verbosity repoCtxt auth uri buildReport = do+  let fullURI = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" }+  transport <- repoContextGetTransport repoCtxt+  res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth)+  case res of+    (303, redir) -> return $ undefined redir --TODO parse redir+    _ -> die' verbosity "unrecognized response" -- give response++{-+  setAllowRedirects False+  (_, response) <- request Request {+    rqURI     = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" },+    rqMethod  = POST,+    rqHeaders = [Header HdrContentType   ("text/plain"),+                 Header HdrContentLength (show (length body)),+                 Header HdrAccept        ("text/plain")],+    rqBody    = body+  }+  case rspCode response of+    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location+#if defined(VERSION_network_uri)+                                     return $ relativeTo rel uri+#elif defined(VERSION_network)+#if MIN_VERSION_network(2,4,0)+                                     return $ relativeTo rel uri+#else+                                     relativeTo rel uri+#endif+#endif+                                  | Header HdrLocation location <- rspHeaders response ]+              -> return $ buildId+    _         -> error "Unrecognised response from server."+  where body  = BuildReport.show buildReport+-}+++-- TODO force this to be a PUT?++putBuildLog :: Verbosity -> RepoContext -> (String, String)+            -> BuildReportId -> BuildLog+            -> IO ()+putBuildLog verbosity repoCtxt auth reportId buildLog = do+  let fullURI = reportId {uriPath = uriPath reportId </> "log"}+  transport <- repoContextGetTransport repoCtxt+  res <- postHttp transport verbosity fullURI buildLog (Just auth)+  case res of+    (200, _) -> return ()+    _ -> die' verbosity "unrecognized response" -- give response
+ src/Distribution/Client/Check.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Check+-- Copyright   :  (c) Lennart Kolmodin 2008+-- License     :  BSD-like+--+-- Maintainer  :  kolmodin@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Check a package for common mistakes+--+-----------------------------------------------------------------------------+module Distribution.Client.Check (+    check+  ) where+++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Utils.Parsec              (renderParseError)+import Distribution.PackageDescription               (GenericPackageDescription)+import Distribution.PackageDescription.Check+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parsec+       (parseGenericPackageDescription, runParseResult)+import Distribution.Parsec                           (PWarning (..), showPError, showPWarning)+import Distribution.Simple.Utils                     (defaultPackageDesc, die', notice, warn)+import System.IO                                     (hPutStr, stderr)++import qualified Data.ByteString  as BS+import qualified System.Directory as Dir++readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)+readGenericPackageDescriptionCheck verbosity fpath = do+    exists <- Dir.doesFileExist fpath+    unless exists $+      die' verbosity $+        "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."+    bs <- BS.readFile fpath+    let (warnings, result) = runParseResult (parseGenericPackageDescription bs)+    case result of+        Left (_, errors) -> do+            traverse_ (warn verbosity . showPError fpath) errors+            hPutStr stderr $ renderParseError fpath bs errors warnings+            die' verbosity "parse error"+        Right x  -> return (warnings, x)++-- | Note: must be called with the CWD set to the directory containing+-- the '.cabal' file.+check :: Verbosity -> IO Bool+check verbosity = do+    pdfile <- defaultPackageDesc verbosity+    (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile+    -- convert parse warnings into PackageChecks+    -- Note: we /could/ pick different levels, based on warning type.+    let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ]+    -- flatten the generic package description into a regular package+    -- description+    -- TODO: this may give more warnings than it should give;+    --       consider two branches of a condition, one saying+    --          ghc-options: -Wall+    --       and the other+    --          ghc-options: -Werror+    --      joined into+    --          ghc-options: -Wall -Werror+    --      checkPackages will yield a warning on the last line, but it+    --      would not on each individual branch.+    --      Hovever, this is the same way hackage does it, so we will yield+    --      the exact same errors as it will.+    let pkg_desc = flattenPackageDescription ppd+    ioChecks <- checkPackageFiles verbosity pkg_desc "."+    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws'+        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]+        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]+        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]+                          ++ [ x | x@PackageDistSuspiciousWarn {}  <- packageChecks ]+        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]++    unless (null buildImpossible) $ do+        warn verbosity "The package will not build sanely due to these errors:"+        printCheckMessages buildImpossible++    unless (null buildWarning) $ do+        warn verbosity "The following warnings are likely to affect your build negatively:"+        printCheckMessages buildWarning++    unless (null distSuspicious) $ do+        warn verbosity "These warnings may cause trouble when distributing the package:"+        printCheckMessages distSuspicious++    unless (null distInexusable) $ do+        warn verbosity "The following errors will cause portability problems on other environments:"+        printCheckMessages distInexusable++    let isDistError (PackageDistSuspicious     {}) = False+        isDistError (PackageDistSuspiciousWarn {}) = False+        isDistError _                              = True+        isCheckError (PackageDistSuspiciousWarn {}) = False+        isCheckError _                              = True+        errors = filter isDistError packageChecks++    unless (null errors) $+        warn verbosity "Hackage would reject this package."++    when (null packageChecks) $+        notice verbosity "No errors or warnings could be found in the package."++    return (not . any isCheckError $ packageChecks)++  where+    printCheckMessages = traverse_ (warn verbosity . explanation)
+ src/Distribution/Client/CmdBench.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE RecordWildCards #-}++-- | cabal-install CLI command: bench+--+module Distribution.Client.CmdBench (+    -- * The @bench@ CLI and action+    benchCommand,+    benchAction,++    -- * Internals exposed for testing+    componentNotBenchmarkProblem,+    isSubComponentProblem,+    noBenchmarksProblem,+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages+         ( renderTargetSelector, showTargetSelector, renderTargetProblem,+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,+           targetSelectorFilter )+import Distribution.Client.TargetProblem+         ( TargetProblem (..) )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Verbosity+         ( normal )+import Distribution.Simple.Utils+         ( wrapText, die' )++benchCommand :: CommandUI (NixStyleFlags ())+benchCommand = CommandUI {+  commandName         = "v2-bench",+  commandSynopsis     = "Run benchmarks",+  commandUsage        = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Runs the specified benchmarks, first ensuring they are up to "+     ++ "date.\n\n"++     ++ "Any benchmark in any package in the project can be specified. "+     ++ "A package can be specified in which case all the benchmarks in the "+     ++ "package are run. The default is to run all the benchmarks in the "+     ++ "package in the current directory.\n\n"++     ++ "Dependencies are built or rebuilt as necessary. Additional "+     ++ "configuration flags can be specified on the command line and these "+     ++ "extend the project configuration from the 'cabal.project', "+     ++ "'cabal.project.local' and other files.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " v2-bench\n"+     ++ "    Run all the benchmarks in the package in the current directory\n"+     ++ "  " ++ pname ++ " v2-bench pkgname\n"+     ++ "    Run all the benchmarks in the package named pkgname\n"+     ++ "  " ++ pname ++ " v2-bench cname\n"+     ++ "    Run the benchmark named cname\n"+     ++ "  " ++ pname ++ " v2-bench cname -O2\n"+     ++ "    Run the benchmark built with '-O2' (including local libs used)\n"++   , commandDefaultFlags = defaultNixStyleFlags ()+   , commandOptions      = nixStyleOptions (const [])+   }+++-- | The @build@ command does a lot. It brings the install plan up to date,+-- selects that part of the plan needed by the given or implicit targets and+-- then executes the plan.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do++    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do++            when (buildSettingOnlyDeps (buildSettings baseCtx)) $+              die' verbosity $+                  "The bench command does not support '--only-dependencies'. "+               ++ "You may wish to use 'build --only-dependencies' and then "+               ++ "use 'bench'."++            -- Interpret the targets on the command line as bench targets+            -- (as opposed to say build or haddock targets).+            targets <- either (reportTargetProblems verbosity) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBench+                                    targets+                                    elaboratedPlan+            return (elaboratedPlan', targets)++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags +                  mempty -- ClientInstallFlags, not needed here++-- | This defines what a 'TargetSelector' means for the @bench@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @bench@ command we select all buildable benchmarks,+-- or fail if there are no benchmarks or no buildable benchmarks.+--+selectPackageTargets :: TargetSelector+                     -> [AvailableTarget k] -> Either BenchTargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there are any buildable benchmark targets then we select those+  | not (null targetsBenchBuildable)+  = Right targetsBenchBuildable++    -- If there are benchmarks but none are buildable then we report those+  | not (null targetsBench)+  = Left (TargetProblemNoneEnabled targetSelector targetsBench)++    -- If there are no benchmarks but some other targets then we report that+  | not (null targets)+  = Left (noBenchmarksProblem targetSelector)++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targetsBenchBuildable = selectBuildableTargets+                          . filterTargetsKind BenchKind+                          $ targets++    targetsBench          = forgetTargetsDetail+                          . filterTargetsKind BenchKind+                          $ targets+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @bench@ command we just need to check it is a benchmark, in addition+-- to the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either BenchTargetProblem k+selectComponentTarget subtarget@WholeComponent t+  | CBenchName _ <- availableTargetComponentName t+  = selectComponentTargetBasic subtarget t+  | otherwise+  = Left (componentNotBenchmarkProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t))++selectComponentTarget subtarget t+  = Left (isSubComponentProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.+--+data BenchProblem =+     -- | The 'TargetSelector' matches targets but no benchmarks+     TargetProblemNoBenchmarks TargetSelector++     -- | The 'TargetSelector' refers to a component that is not a benchmark+   | TargetProblemComponentNotBenchmark PackageId ComponentName++     -- | Asking to benchmark an individual file or module is not supported+   | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget+  deriving (Eq, Show)+++type BenchTargetProblem = TargetProblem BenchProblem++noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem+noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks++componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem+componentNotBenchmarkProblem pkgid name = CustomTargetProblem $+  TargetProblemComponentNotBenchmark pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem BenchProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+    TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderBenchTargetProblem++renderBenchTargetProblem :: BenchTargetProblem -> String+renderBenchTargetProblem (TargetProblemNoTargets targetSelector) =+    case targetSelectorFilter targetSelector of+      Just kind | kind /= BenchKind+        -> "The bench command is for running benchmarks, but the target '"+           ++ showTargetSelector targetSelector ++ "' refers to "+           ++ renderTargetSelector targetSelector ++ "."++      _ -> renderTargetProblemNoTargets "benchmark" targetSelector+renderBenchTargetProblem problem =+    renderTargetProblem "benchmark" renderBenchProblem problem++renderBenchProblem :: BenchProblem -> String+renderBenchProblem (TargetProblemNoBenchmarks targetSelector) =+    "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any benchmarks."++renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) =+    "The bench command is for running benchmarks, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ prettyShow pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+    "The bench command can only run benchmarks as a whole, "+ ++ "not files or modules within them, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ "."+  where+    targetSelector = TargetComponent pkgid cname subtarget
+ src/Distribution/Client/CmdBuild.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE RecordWildCards #-}+-- | cabal-install CLI command: build+--+module Distribution.Client.CmdBuild (+    -- * The @build@ CLI and action+    buildCommand,+    buildAction,++    -- * Internals exposed for testing+    selectPackageTargets,+    selectComponentTarget+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.ProjectOrchestration+import Distribution.Client.TargetProblem+         ( TargetProblem (..), TargetProblem' )+import Distribution.Client.CmdErrorMessages++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..), yesNoOpt )+import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives, option, optionName )+import Distribution.Verbosity+         ( normal )+import Distribution.Simple.Utils+         ( wrapText, die' )++import qualified Data.Map as Map+++buildCommand :: CommandUI (NixStyleFlags BuildFlags)+buildCommand = CommandUI {+  commandName         = "v2-build",+  commandSynopsis     = "Compile targets within the project.",+  commandUsage        = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Build one or more targets from within the project. The available "+     ++ "targets are the packages in the project as well as individual "+     ++ "components within those packages, including libraries, executables, "+     ++ "test-suites or benchmarks. Targets can be specified by name or "+     ++ "location. If no target is specified then the default is to build "+     ++ "the package in the current directory.\n\n"++     ++ "Dependencies are built or rebuilt as necessary. Additional "+     ++ "configuration flags can be specified on the command line and these "+     ++ "extend the project configuration from the 'cabal.project', "+     ++ "'cabal.project.local' and other files.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " v2-build\n"+     ++ "    Build the package in the current directory "+     ++ "or all packages in the project\n"+     ++ "  " ++ pname ++ " v2-build pkgname\n"+     ++ "    Build the package named pkgname in the project\n"+     ++ "  " ++ pname ++ " v2-build ./pkgfoo\n"+     ++ "    Build the package in the ./pkgfoo directory\n"+     ++ "  " ++ pname ++ " v2-build cname\n"+     ++ "    Build the component named cname in the project\n"+     ++ "  " ++ pname ++ " v2-build cname --enable-profiling\n"+     ++ "    Build the component in profiling mode "+     ++ "(including dependencies as needed)\n"++  , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags+  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+                        . nixStyleOptions (\showOrParseArgs ->+    [ option [] ["only-configure"]+        "Instead of performing a full build just run the configure step"+        buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v })+        (yesNoOpt showOrParseArgs)+    ])+  }++data BuildFlags = BuildFlags+    { buildOnlyConfigure  :: Flag Bool+    }++defaultBuildFlags :: BuildFlags+defaultBuildFlags = BuildFlags+    { buildOnlyConfigure = toFlag False+    }++-- | The @build@ command does a lot. It brings the install plan up to date,+-- selects that part of the plan needed by the given or implicit targets and+-- then executes the plan.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()+buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do+    -- TODO: This flags defaults business is ugly+    let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags+                                 <> buildOnlyConfigure buildFlags)+        targetAction+            | onlyConfigure = TargetActionConfigure+            | otherwise = TargetActionBuild++    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand++    targetSelectors <-+      either (reportTargetSelectorProblems verbosity) return+      =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do++            -- Interpret the targets on the command line as build targets+            -- (as opposed to say repl or haddock targets).+            targets <- either (reportBuildTargetProblems verbosity) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    targetAction+                                    targets+                                    elaboratedPlan+            elaboratedPlan'' <-+              if buildSettingOnlyDeps (buildSettings baseCtx)+                then either (reportCannotPruneDependencies verbosity) return $+                     pruneInstallPlanToDependencies (Map.keysSet targets)+                                                    elaboratedPlan'+                else return elaboratedPlan'++            return (elaboratedPlan'', targets)++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags+                  mempty -- ClientInstallFlags, not needed here++-- | This defines what a 'TargetSelector' means for the @bench@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @build@ command select all components except non-buildable+-- and disabled tests\/benchmarks, fail if there are no such+-- components+--+selectPackageTargets :: TargetSelector+                     -> [AvailableTarget k] -> Either TargetProblem' [k]+selectPackageTargets targetSelector targets++    -- If there are any buildable targets then we select those+  | not (null targetsBuildable)+  = Right targetsBuildable++    -- If there are targets but none are buildable then we report those+  | not (null targets)+  = Left (TargetProblemNoneEnabled targetSelector targets')++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targets'         = forgetTargetsDetail targets+    targetsBuildable = selectBuildableTargetsWith+                         (buildable targetSelector)+                         targets++    -- When there's a target filter like "pkg:tests" then we do select tests,+    -- but if it's just a target like "pkg" then we don't build tests unless+    -- they are requested by default (i.e. by using --enable-tests)+    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False+    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False+    buildable _ _ = True++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @build@ command we just need the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem' k+selectComponentTarget = selectComponentTargetBasic++reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a+reportBuildTargetProblems verbosity problems =+  reportTargetProblems verbosity "build" problems++reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a+reportCannotPruneDependencies verbosity =+    die' verbosity . renderCannotPruneDependencies
+ src/Distribution/Client/CmdClean.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.CmdClean (cleanCommand, cleanAction) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.DistDirLayout+    ( DistDirLayout(..), defaultDistDirLayout )+import Distribution.Client.ProjectConfig+    ( findProjectRoot )+import Distribution.Client.Setup+    ( GlobalFlags )+import Distribution.ReadE ( succeedReadE )+import Distribution.Simple.Setup+    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe+    , optionDistPref, optionVerbosity, falseArg+    )+import Distribution.Simple.Command+    ( CommandUI(..), option, reqArg )+import Distribution.Simple.Utils+    ( info, die', wrapText, handleDoesNotExist )+import Distribution.Verbosity+    ( normal )++import System.Directory+    ( removeDirectoryRecursive, removeFile+    , doesDirectoryExist, getDirectoryContents )+import System.FilePath+    ( (</>) )++data CleanFlags = CleanFlags+    { cleanSaveConfig  :: Flag Bool+    , cleanVerbosity   :: Flag Verbosity+    , cleanDistDir     :: Flag FilePath+    , cleanProjectFile :: Flag FilePath+    } deriving (Eq)++defaultCleanFlags :: CleanFlags+defaultCleanFlags = CleanFlags+    { cleanSaveConfig  = toFlag False+    , cleanVerbosity   = toFlag normal+    , cleanDistDir     = NoFlag+    , cleanProjectFile = mempty+    }++cleanCommand :: CommandUI CleanFlags+cleanCommand = CommandUI+    { commandName         = "v2-clean"+    , commandSynopsis     = "Clean the package store and remove temporary files."+    , commandUsage        = \pname ->+        "Usage: " ++ pname ++ " new-clean [FLAGS]\n"+    , commandDescription  = Just $ \_ -> wrapText $+        "Removes all temporary files created during the building process "+     ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "+     ++ "local caches (by default).\n\n"+    , commandNotes        = Nothing+    , commandDefaultFlags = defaultCleanFlags+    , commandOptions      = \showOrParseArgs ->+        [ optionVerbosity+            cleanVerbosity (\v flags -> flags { cleanVerbosity = v })+        , optionDistPref+            cleanDistDir (\dd flags -> flags { cleanDistDir = dd })+            showOrParseArgs+        , option [] ["project-file"]+            ("Set the name of the cabal.project file"+             ++ " to search for in parent directories")+            cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf})+            (reqArg "FILE" (succeedReadE Flag) flagToList)+        , option ['s'] ["save-config"]+            "Save configuration, only remove build artifacts"+            cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc })+            falseArg+        ]+  }++cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()+cleanAction CleanFlags{..} extraArgs _ = do+    let verbosity      = fromFlagOrDefault normal cleanVerbosity+        saveConfig     = fromFlagOrDefault False  cleanSaveConfig+        mdistDirectory = flagToMaybe cleanDistDir+        mprojectFile   = flagToMaybe cleanProjectFile++    unless (null extraArgs) $+        die' verbosity $ "'clean' doesn't take any extra arguments: "+                         ++ unwords extraArgs++    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile++    let distLayout = defaultDistDirLayout projectRoot mdistDirectory++    if saveConfig+        then do+            let buildRoot = distBuildRootDirectory distLayout++            buildRootExists <- doesDirectoryExist buildRoot++            when buildRootExists $ do+                info verbosity ("Deleting build root (" ++ buildRoot ++ ")")+                handleDoesNotExist () $ removeDirectoryRecursive buildRoot+        else do+            let distRoot = distDirectory distLayout++            info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")+            handleDoesNotExist () $ removeDirectoryRecursive distRoot++    removeEnvFiles (distProjectRootDirectory distLayout)++removeEnvFiles :: FilePath -> IO ()+removeEnvFiles dir =+  (traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))+  =<< getDirectoryContents dir
+ src/Distribution/Client/CmdConfigure.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE RecordWildCards #-}+-- | cabal-install CLI command: configure+--+module Distribution.Client.CmdConfigure (+    configureCommand,+    configureAction,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import System.Directory+import System.FilePath+import qualified Data.Map as Map++import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+         ( writeProjectLocalExtraConfig )++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault )+import Distribution.Verbosity+         ( normal )++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives, optionName )+import Distribution.Simple.Utils+         ( wrapText, notice )++import Distribution.Client.DistDirLayout+         ( DistDirLayout(..) )++configureCommand :: CommandUI (NixStyleFlags ())+configureCommand = CommandUI {+  commandName         = "v2-configure",+  commandSynopsis     = "Add extra project configuration",+  commandUsage        = usageAlternatives "v2-configure" [ "[FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Adjust how the project is built by setting additional package flags "+     ++ "and other flags.\n\n"++     ++ "The configuration options are written to the 'cabal.project.local' "+     ++ "file (or '$project_file.local', if '--project-file' is specified) "+     ++ "which extends the configuration from the 'cabal.project' file "+     ++ "(if any). This combination is used as the project configuration for "+     ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it "+     ++ "can be extended/overridden on a per-command basis.\n\n"++     ++ "The v2-configure command also checks that the project configuration "+     ++ "will work. In particular it checks that there is a consistent set of "+     ++ "dependencies for the project as a whole.\n\n"++     ++ "The 'cabal.project.local' file persists across 'v2-clean' but is "+     ++ "overwritten on the next use of the 'v2-configure' command. The "+     ++ "intention is that the 'cabal.project' file should be kept in source "+     ++ "control but the 'cabal.project.local' should not.\n\n"++     ++ "It is never necessary to use the 'v2-configure' command. It is "+     ++ "merely a convenience in cases where you do not want to specify flags "+     ++ "to 'v2-build' (and other commands) every time and yet do not want "+     ++ "to alter the 'cabal.project' persistently.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n"+     ++ "    Adjust the project configuration to use the given compiler\n"+     ++ "    program and check the resulting configuration works.\n"+     ++ "  " ++ pname ++ " v2-configure\n"+     ++ "    Reset the local configuration to empty and check the overall\n"+     ++ "    project configuration works.\n"++  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+                        . nixStyleOptions (const [])+  }++-- | To a first approximation, the @configure@ just runs the first phase of+-- the @build@ command where we bring the install plan up to date (thus+-- checking that it's possible).+--+-- The only difference is that @configure@ also allows the user to specify+-- some extra config flags which we save in the file @cabal.project.local@.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do+    --TODO: deal with _extraArgs, since flags with wrong syntax end up there++    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand++    -- Write out the @cabal.project.local@ so it gets picked up by the+    -- planning phase. If old config exists, then print the contents+    -- before overwriting++    let localFile = distProjectFile (distDirLayout baseCtx) "local"+        -- | Chooses cabal.project.local~, or if it already exists+        -- cabal.project.local~0, cabal.project.local~1 etc.+        firstFreeBackup = firstFreeBackup' (0 :: Int)+        firstFreeBackup' i = do+          let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1))+          exists <- doesFileExist backup+          if exists+            then firstFreeBackup' (i + 1)+            else return backup+        dryRun = buildSettingDryRun (buildSettings baseCtx)+              || buildSettingOnlyDownload (buildSettings baseCtx)++    if dryRun+       then notice verbosity "Config file not written due to flag(s)."+       else do+          -- If cabal.project.local already exists, back up to cabal.project.local~[n]+          exists <- doesFileExist localFile+          when exists $ do+              backup <- firstFreeBackup+              notice verbosity $+                quote (takeFileName localFile) <> " already exists, backing it up to "+                <> quote (takeFileName backup) <> "."+              copyFile localFile backup+          writeProjectLocalExtraConfig (distDirLayout baseCtx)+                                       cliConfig++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan ->++            -- TODO: Select the same subset of targets as 'CmdBuild' would+            -- pick (ignoring, for example, executables in libraries+            -- we depend on). But we don't want it to fail, so actually we+            -- have to do it slightly differently from build.+            return (elaboratedPlan, Map.empty)++    let baseCtx' = baseCtx {+                      buildSettings = (buildSettings baseCtx) {+                        buildSettingDryRun = True+                      }+                    }++    -- TODO: Hmm, but we don't have any targets. Currently this prints+    -- what we would build if we were to build everything. Could pick+    -- implicit target like "."+    --+    -- TODO: should we say what's in the project (+deps) as a whole?+    printPlan verbosity baseCtx' buildCtx+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags+                  mempty -- ClientInstallFlags, not needed here+    quote s = "'" <> s <> "'"+
+ src/Distribution/Client/CmdErrorMessages.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+++-- | Utilities to help format error messages for the various CLI commands.+--+module Distribution.Client.CmdErrorMessages (+    module Distribution.Client.CmdErrorMessages,+    module Distribution.Client.TargetSelector,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ProjectPlanning+         ( AvailableTarget(..), AvailableTargetStatus(..),+           CannotPruneDependencies(..), TargetRequested(..) )+import Distribution.Client.TargetSelector+         ( SubComponentTarget(..) )+import Distribution.Client.TargetProblem+         ( TargetProblem(..), TargetProblem' )+import Distribution.Client.TargetSelector+         ( ComponentKind(..), ComponentKindFilter, TargetSelector(..),+           componentKind, showTargetSelector )++import Distribution.Package+         ( PackageId, packageId, PackageName, packageName )+import Distribution.Simple.Utils+         ( die' )+import Distribution.Types.ComponentName+         ( ComponentName(..), showComponentName )+import Distribution.Types.LibraryName+         ( LibraryName(..) )+import Distribution.Solver.Types.OptionalStanza+         ( OptionalStanza(..) )++import qualified Data.List.NonEmpty as NE+++-----------------------+-- Singular or plural+--++-- | A tag used in rendering messages to distinguish singular or plural.+--+data Plural = Singular | Plural++-- | Used to render a singular or plural version of something+--+-- > plural (listPlural theThings) "it is" "they are"+--+plural :: Plural -> a -> a -> a+plural Singular si _pl = si+plural Plural  _si  pl = pl++-- | Singular for singleton lists and plural otherwise.+--+listPlural :: [a] -> Plural+listPlural [_] = Singular+listPlural  _  = Plural+++--------------------+-- Rendering lists+--++-- | Render a list of things in the style @foo, bar and baz@+renderListCommaAnd :: [String] -> String+renderListCommaAnd []     = ""+renderListCommaAnd [x]    = x+renderListCommaAnd [x,x'] = x ++ " and " ++ x'+renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs++-- | Render a list of things in the style @blah blah; this that; and the other@+renderListSemiAnd :: [String] -> String+renderListSemiAnd []     = ""+renderListSemiAnd [x]    = x+renderListSemiAnd [x,x'] = x ++ "; and " ++ x'+renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs++-- | When rendering lists of things it often reads better to group related+-- things, e.g. grouping components by package name+--+-- > renderListSemiAnd+-- >   [     "the package " ++ prettyShow pkgname ++ " components "+-- >      ++ renderListCommaAnd showComponentName components+-- >   | (pkgname, components) <- sortGroupOn packageName allcomponents ]+--+sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])]+sortGroupOn key = map (\(x:|xs) -> (key x, x:xs))+                . NE.groupBy ((==) `on` key)+                . sortBy  (compare `on` key)+++----------------------------------------------------+-- Renderering for a few project and package types+--++renderTargetSelector :: TargetSelector -> String+renderTargetSelector (TargetPackage _ pkgids Nothing) =+    "the " ++ plural (listPlural pkgids) "package" "packages" ++ " "+ ++ renderListCommaAnd (map prettyShow pkgids)++renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) =+    "the " ++ renderComponentKind Plural kfilter+ ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " "+ ++ renderListCommaAnd (map prettyShow pkgids)++renderTargetSelector (TargetPackageNamed pkgname Nothing) =+    "the package " ++ prettyShow pkgname++renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) =+    "the " ++ renderComponentKind Plural kfilter+ ++ " in the package " ++ prettyShow pkgname++renderTargetSelector (TargetAllPackages Nothing) =+    "all the packages in the project"++renderTargetSelector (TargetAllPackages (Just kfilter)) =+    "all the " ++ renderComponentKind Plural kfilter+ ++ " in the project"++renderTargetSelector (TargetComponent pkgid cname subtarget) =+    renderSubComponentTarget subtarget ++ "the "+ ++ renderComponentName (packageName pkgid) cname++renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) =+    renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname+ ++ " in the package " ++ prettyShow pkgname++renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) =+    renderSubComponentTarget subtarget ++ "the "+ ++ renderComponentName pkgname cname++renderSubComponentTarget :: SubComponentTarget -> String+renderSubComponentTarget WholeComponent         = ""+renderSubComponentTarget (FileTarget filename)  =+  "the file " ++ filename ++ " in "+renderSubComponentTarget (ModuleTarget modname) =+  "the module " ++ prettyShow modname ++ " in "+++renderOptionalStanza :: Plural -> OptionalStanza -> String+renderOptionalStanza Singular TestStanzas  = "test suite"+renderOptionalStanza Plural   TestStanzas  = "test suites"+renderOptionalStanza Singular BenchStanzas = "benchmark"+renderOptionalStanza Plural   BenchStanzas = "benchmarks"++-- | The optional stanza type (test suite or benchmark), if it is one.+optionalStanza :: ComponentName -> Maybe OptionalStanza+optionalStanza (CTestName  _) = Just TestStanzas+optionalStanza (CBenchName _) = Just BenchStanzas+optionalStanza _              = Nothing++-- | Does the 'TargetSelector' potentially refer to one package or many?+--+targetSelectorPluralPkgs :: TargetSelector -> Plural+targetSelectorPluralPkgs (TargetAllPackages _)     = Plural+targetSelectorPluralPkgs (TargetPackage _ pids _)  = listPlural pids+targetSelectorPluralPkgs (TargetPackageNamed _ _)  = Singular+targetSelectorPluralPkgs  TargetComponent{}        = Singular+targetSelectorPluralPkgs  TargetComponentUnknown{} = Singular++-- | Does the 'TargetSelector' refer to packages or to components?+targetSelectorRefersToPkgs :: TargetSelector -> Bool+targetSelectorRefersToPkgs (TargetAllPackages    mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs (TargetPackage    _ _ mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter+targetSelectorRefersToPkgs  TargetComponent{}              = False+targetSelectorRefersToPkgs  TargetComponentUnknown{}       = False++targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter+targetSelectorFilter (TargetPackage    _ _ mkfilter) = mkfilter+targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter+targetSelectorFilter (TargetAllPackages    mkfilter) = mkfilter+targetSelectorFilter  TargetComponent{}              = Nothing+targetSelectorFilter  TargetComponentUnknown{}       = Nothing++renderComponentName :: PackageName -> ComponentName -> String+renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname+renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name+renderComponentName _ (CFLibName   name) = "foreign library " ++ prettyShow name+renderComponentName _ (CExeName    name) = "executable " ++ prettyShow name+renderComponentName _ (CTestName   name) = "test suite " ++ prettyShow name+renderComponentName _ (CBenchName  name) = "benchmark " ++ prettyShow name++renderComponentKind :: Plural -> ComponentKind -> String+renderComponentKind Singular ckind = case ckind of+  LibKind   -> "library"  -- internal/sub libs?+  FLibKind  -> "foreign library"+  ExeKind   -> "executable"+  TestKind  -> "test suite"+  BenchKind -> "benchmark"+renderComponentKind Plural ckind = case ckind of+  LibKind   -> "libraries"  -- internal/sub libs?+  FLibKind  -> "foreign libraries"+  ExeKind   -> "executables"+  TestKind  -> "test suites"+  BenchKind -> "benchmarks"+++-------------------------------------------------------+-- Renderering error messages for TargetProblem+--++-- | Default implementation of 'reportTargetProblems' simply renders one problem per line.+reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a+reportTargetProblems verbosity verb =+  die' verbosity . unlines . map (renderTargetProblem verb absurd)++-- | Default implementation of 'renderTargetProblem'.+renderTargetProblem+    :: String           -- ^ verb+    -> (a -> String)    -- ^ how to render custom problems+    -> TargetProblem a+    -> String+renderTargetProblem _verb f (CustomTargetProblem x) = f x+renderTargetProblem verb  _ (TargetProblemNoneEnabled targetSelector targets) =+    renderTargetProblemNoneEnabled verb targetSelector targets+renderTargetProblem verb  _ (TargetProblemNoTargets targetSelector) =+    renderTargetProblemNoTargets verb targetSelector++renderTargetProblem verb _ (TargetNotInProject pkgname) =+    "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "+ ++ "in this project (either directly or indirectly). If you want to add it "+ ++ "to the project then edit the cabal.project file."++renderTargetProblem verb _ (TargetAvailableInIndex pkgname) =+    "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "+ ++ "in this project (either directly or indirectly), but it is in the current "+ ++ "package index. If you want to add it to the project then edit the "+ ++ "cabal.project file."++renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "+ ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal "+ ++ "does not currently support building test suites or benchmarks of "+ ++ "non-local dependencies. To run test suites or benchmarks from "+ ++ "dependencies you can unpack the package locally and adjust the "+ ++ "cabal.project file to include that package directory."++renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is "+ ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid)+ ++ ".cabal' file (at least for the current configuration). If you believe it "+ ++ "should be buildable then check the .cabal file to see if the buildable "+ ++ "property is conditional on flags. Alternatively you may simply have to "+ ++ "edit the .cabal file to declare it as buildable and fix any resulting "+ ++ "build problems."++renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because "+ ++ "building " ++ compkinds ++ " has been explicitly disabled in the "+ ++ "configuration. You can adjust this configuration in the "+ ++ "cabal.project{.local} file either for all packages in the project or on "+ ++ "a per-package basis. Note that if you do not explicitly disable "+ ++ compkinds ++ " then the solver will merely try to make a plan with "+ ++ "them available, so you may wish to explicitly enable them which will "+ ++ "require the solver to find a plan with them available or to fail with an "+ ++ "explanation."+   where+     compkinds = renderComponentKind Plural (componentKind cname)++renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) =+    "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "+ ++ "solver did not find a plan that included the " ++ compkinds+ ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with "+ ++ compkinds ++ " explicitly enabled in the configuration in the "+ ++ "cabal.project{.local} file. This will ask the solver to find a plan with "+ ++ "the " ++ compkinds ++ " available. It will either fail with an "+ ++ "explanation or find a different plan that uses different versions of some "+ ++ "other packages. Use the '--dry-run' flag to see package versions and "+ ++ "check that you are happy with the choices."+   where+     compkinds = renderComponentKind Plural (componentKind cname)++renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) =+    "Cannot " ++ verb ++ " the "+ ++ (case ecname of+      Left ucname -> "component " ++ prettyShow ucname+      Right cname -> renderComponentName pkgname cname)+ ++ " from the package " ++ prettyShow pkgname+ ++ ", because the package does not contain a "+ ++ (case ecname of+      Left  _     -> "component"+      Right cname -> renderComponentKind Singular (componentKind cname))+ ++ " with that name."++renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) =+    "Internal error when trying to " ++ verb ++ " the package "+  ++ prettyShow pkgid ++ ". The package is not in the set of available targets "+  ++ "for the project plan, which would suggest an inconsistency "+  ++ "between readTargetSelectors and resolveTargets."++renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) =+    "Internal error when trying to " ++ verb ++ " the "+  ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid+  ++ ". The package,component pair is not in the set of available targets "+  ++ "for the project plan, which would suggest an inconsistency "+  ++ "between readTargetSelectors and resolveTargets."+++------------------------------------------------------------+-- Renderering error messages for TargetProblemNoneEnabled+--++-- | Several commands have a @TargetProblemNoneEnabled@ problem constructor.+-- This renders an error message for those cases.+--+renderTargetProblemNoneEnabled :: String+                               -> TargetSelector+                               -> [AvailableTarget ()]+                               -> String+renderTargetProblemNoneEnabled verb targetSelector targets =+    "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector+ ++ " because none of the components are available to build: "+ ++ renderListSemiAnd+    [ case (status, mstanza) of+        (TargetDisabledByUser, Just stanza) ->+            renderListCommaAnd+              [ "the " ++ showComponentName availableTargetComponentName+              | AvailableTarget {availableTargetComponentName} <- targets' ]+         ++ plural (listPlural targets') " is " " are "+         ++ " not available because building "+         ++ renderOptionalStanza Plural stanza+         ++ " has been disabled in the configuration"+        (TargetDisabledBySolver, Just stanza) ->+            renderListCommaAnd+              [ "the " ++ showComponentName availableTargetComponentName+              | AvailableTarget {availableTargetComponentName} <- targets' ]+         ++ plural (listPlural targets') " is " " are "+         ++ "not available because the solver did not find a plan that "+         ++ "included the " ++ renderOptionalStanza Plural stanza+         ++ ". Force the solver to enable this for all packages by adding the "+         ++ "line 'tests: True' to the 'cabal.project.local' file."+        (TargetNotBuildable, _) ->+            renderListCommaAnd+              [ "the " ++ showComponentName availableTargetComponentName+              | AvailableTarget {availableTargetComponentName} <- targets' ]+         ++ plural (listPlural targets') " is " " are all "+         ++ "marked as 'buildable: False'"+        (TargetNotLocal, _) ->+            renderListCommaAnd+              [ "the " ++ showComponentName availableTargetComponentName+              | AvailableTarget {availableTargetComponentName} <- targets' ]+         ++ " cannot be built because cabal does not currently support "+         ++ "building test suites or benchmarks of non-local dependencies"+        (TargetBuildable () TargetNotRequestedByDefault, Just stanza) ->+            renderListCommaAnd+              [ "the " ++ showComponentName availableTargetComponentName+              | AvailableTarget {availableTargetComponentName} <- targets' ]+         ++ " will not be built because " ++ renderOptionalStanza Plural stanza+         ++ " are not built by default in the current configuration (but you "+         ++ "can still build them specifically)" --TODO: say how+        _ -> error $ "renderBuildTargetProblem: unexpected status "+                  ++ show (status, mstanza)+    | ((status, mstanza), targets') <- sortGroupOn groupingKey targets+    ]+  where+    groupingKey t =+      ( availableTargetStatus t+      , case availableTargetStatus t of+          TargetNotBuildable -> Nothing+          TargetNotLocal     -> Nothing+          _ -> optionalStanza (availableTargetComponentName t)+      )++------------------------------------------------------------+-- Renderering error messages for TargetProblemNoneEnabled+--++-- | Several commands have a @TargetProblemNoTargets@ problem constructor.+-- This renders an error message for those cases.+--+renderTargetProblemNoTargets :: String -> TargetSelector -> String+renderTargetProblemNoTargets verb targetSelector =+    "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector+ ++ " because " ++ reason targetSelector ++ ". "+ ++ "Check the .cabal "+ ++ plural (targetSelectorPluralPkgs targetSelector)+      "file for the package and make sure that it properly declares "+      "files for the packages and make sure that they properly declare "+ ++ "the components that you expect."+  where+    reason (TargetPackage _ _ Nothing) =+        "it does not contain any components at all"+    reason (TargetPackage _ _ (Just kfilter)) =+        "it does not contain any " ++ renderComponentKind Plural kfilter+    reason (TargetPackageNamed _ Nothing) =+        "it does not contain any components at all"+    reason (TargetPackageNamed _ (Just kfilter)) =+        "it does not contain any " ++ renderComponentKind Plural kfilter+    reason (TargetAllPackages Nothing) =+        "none of them contain any components at all"+    reason (TargetAllPackages (Just kfilter)) =+        "none of the packages contain any "+     ++ renderComponentKind Plural kfilter+    reason ts@TargetComponent{} =+        error $ "renderTargetProblemNoTargets: " ++ show ts+    reason ts@TargetComponentUnknown{} =+        error $ "renderTargetProblemNoTargets: " ++ show ts++-----------------------------------------------------------+-- Renderering error messages for CannotPruneDependencies+--++renderCannotPruneDependencies :: CannotPruneDependencies -> String+renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =+      "Cannot select only the dependencies (as requested by the "+   ++ "'--only-dependencies' flag), "+   ++ (case pkgids of+          [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "+          _       -> "the packages "+                     ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ")+   ++ "required by a dependency of one of the other targets."+  where+    -- throw away the details and just list the deps that are needed+    pkgids :: [PackageId]+    pkgids = nub . map packageId . concatMap snd $ brokenPackages++{-+           ++ "Syntax:\n"+           ++ " - build [package]\n"+           ++ " - build [package:]component\n"+           ++ " - build [package:][component:]module\n"+           ++ " - build [package:][component:]file\n"+           ++ " where\n"+           ++ "  package is a package name, package dir or .cabal file\n\n"+           ++ "Examples:\n"+           ++ " - build foo            -- package name\n"+           ++ " - build tests          -- component name\n"+           ++ "    (name of library, executable, test-suite or benchmark)\n"+           ++ " - build Data.Foo       -- module name\n"+           ++ " - build Data/Foo.hsc   -- file name\n\n"+           ++ "An ambigious target can be qualified by package, component\n"+           ++ "and/or component kind (lib|exe|test|bench|flib)\n"+           ++ " - build foo:tests      -- component qualified by package\n"+           ++ " - build tests:Data.Foo -- module qualified by component\n"+           ++ " - build lib:foo        -- component qualified by kind"+-}
+ src/Distribution/Client/CmdExec.hs view
@@ -0,0 +1,258 @@+-------------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Exec+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'v2-exec' command for running an arbitrary executable+-- in an environment suited to the part of the store built for a project.+-------------------------------------------------------------------------------++{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.CmdExec+  ( execAction+  , execCommand+  ) where++import Distribution.Client.DistDirLayout+  ( DistDirLayout(..)+  )+import Distribution.Client.InstallPlan+  ( GenericPlanPackage(..)+  , toGraph+  )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+  ( ConfigFlags(configVerbosity)+  , GlobalFlags+  )+import Distribution.Client.ProjectOrchestration+  ( ProjectBuildContext(..)+  , runProjectPreBuildPhase+  , CurrentCommand(..)+  , establishProjectBaseContext+  , distDirLayout+  , commandLineFlagsToProjectConfig+  , ProjectBaseContext(..)+  , BuildTimeSettings(..)+  )+import Distribution.Client.ProjectPlanOutput+  ( updatePostBuildProjectStatus+  , createPackageEnvironment+  , argsEquivalentOfGhcEnvironmentFile+  , PostBuildProjectStatus+  )+import qualified Distribution.Client.ProjectPlanning as Planning+import Distribution.Client.ProjectPlanning+  ( ElaboratedInstallPlan+  , ElaboratedSharedConfig(..)+  )+import Distribution.Simple.Command+  ( CommandUI(..), optionName+  )+import Distribution.Simple.Program.Db+  ( modifyProgramSearchPath+  , requireProgram+  , configuredPrograms+  )+import Distribution.Simple.Program.Find+  ( ProgramSearchPathEntry(..)+  )+import Distribution.Simple.Program.Run+  ( programInvocation+  , runProgramInvocation+  )+import Distribution.Simple.Program.Types+  ( programOverrideEnv+  , programDefaultArgs+  , programPath+  , simpleProgram+  , ConfiguredProgram+  )+import Distribution.Simple.GHC+  ( getImplInfo+  , GhcImplInfo(supportsPkgEnvFiles) )+import Distribution.Simple.Flag+  ( fromFlagOrDefault+  )+import Distribution.Simple.Utils+  ( die'+  , info+  , createDirectoryIfMissingVerbose+  , withTempDirectory+  , wrapText+  , notice+  )+import Distribution.Verbosity+  ( normal+  )++import Prelude ()+import Distribution.Client.Compat.Prelude++import qualified Data.Set as S+import qualified Data.Map as M++execCommand :: CommandUI (NixStyleFlags ())+execCommand = CommandUI+  { commandName = "v2-exec"+  , commandSynopsis = "Give a command access to the store."+  , commandUsage = \pname ->+    "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n"+  , commandDescription = Just $ \pname -> wrapText $+       "During development it is often useful to run build tasks and perform"+    ++ " one-off program executions to experiment with the behavior of build"+    ++ " tools. It is convenient to run these tools in the same way " ++ pname+    ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to"+    ++ " do so.\n"+    ++ "\n"+    ++ "Compiler tools will be configured to see the same subset of the store"+    ++ " that builds would see. The PATH is modified to make all executables in"+    ++ " the dependency tree available (provided they have been built already)."+    ++ " Commands are also rewritten in the way cabal itself would. For"+    ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration"+    ++ " to choose an appropriate version of ghc and to include any"+    ++ " ghc-specific flags requested."+  , commandNotes = Nothing+  , commandOptions      = filter (\o -> optionName o /= "ignore-project")+                        . nixStyleOptions (const [])+  , commandDefaultFlags = defaultNixStyleFlags ()+  }++execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+execAction flags@NixStyleFlags {..} extraArgs globalFlags = do++  baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand++  -- To set up the environment, we'd like to select the libraries in our+  -- dependency tree that we've already built. So first we set up an install+  -- plan, but we walk the dependency tree without first executing the plan.+  buildCtx <- runProjectPreBuildPhase+    verbosity+    baseCtx+    (\plan -> return (plan, M.empty))++  -- We use the build status below to decide what libraries to include in the+  -- compiler environment, but we don't want to actually build anything. So we+  -- pass mempty to indicate that nothing happened and we just want the current+  -- status.+  buildStatus <- updatePostBuildProjectStatus+    verbosity+    (distDirLayout baseCtx)+    (elaboratedPlanOriginal buildCtx)+    (pkgsBuildStatus buildCtx)+    mempty++  -- Some dependencies may have executables. Let's put those on the PATH.+  extraPaths <- pathAdditions verbosity baseCtx buildCtx+  let programDb = modifyProgramSearchPath+                  (map ProgramSearchPathDir extraPaths ++)+                . pkgConfigCompilerProgs+                . elaboratedShared+                $ buildCtx++  -- Now that we have the packages, set up the environment. We accomplish this+  -- by creating an environment file that selects the databases and packages we+  -- computed in the previous step, and setting an environment variable to+  -- point at the file.+  -- In case ghc is too old to support environment files,+  -- we pass the same info as arguments+  let compiler = pkgConfigCompiler $ elaboratedShared buildCtx+      envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)+  case extraArgs of+    [] -> die' verbosity "Please specify an executable to run"+    exe:args -> do+      (program, _) <- requireProgram verbosity (simpleProgram exe) programDb+      let argOverrides =+            argsEquivalentOfGhcEnvironmentFile+              compiler+              (distDirLayout baseCtx)+              (elaboratedPlanOriginal buildCtx)+              buildStatus+          programIsConfiguredCompiler = matchCompilerPath+                                          (elaboratedShared buildCtx)+                                          program+          argOverrides' =+            if envFilesSupported+            || not programIsConfiguredCompiler+            then []+            else argOverrides++      (if envFilesSupported+      then withTempEnvFile verbosity baseCtx buildCtx buildStatus+      else \f -> f []) $ \envOverrides -> do+        let program'   = withOverrides+                           envOverrides+                           argOverrides'+                           program+            invocation = programInvocation program' args+            dryRun = buildSettingDryRun (buildSettings baseCtx)+                  || buildSettingOnlyDownload (buildSettings baseCtx)++        if dryRun+           then notice verbosity "Running of executable suppressed by flag(s)"+           else runProgramInvocation verbosity invocation+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags+                  mempty -- ClientInstallFlags, not needed here+    withOverrides env args program = program+      { programOverrideEnv = programOverrideEnv program ++ env+      , programDefaultArgs = programDefaultArgs program ++ args}++matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool+matchCompilerPath elaboratedShared program =+  programPath program+  `elem`+  (programPath <$> configuredCompilers)+  where+    configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared++-- | Execute an action with a temporary .ghc.environment file reflecting the+-- current environment. The action takes an environment containing the env+-- variable which points ghc to the file.+withTempEnvFile :: Verbosity+                -> ProjectBaseContext+                -> ProjectBuildContext+                -> PostBuildProjectStatus+                -> ([(String, Maybe String)] -> IO a)+                -> IO a+withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do+  createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx))+  withTempDirectory+   verbosity+   (distTempDirectory (distDirLayout baseCtx))+   "environment."+   (\tmpDir -> do+     envOverrides <- createPackageEnvironment+       verbosity+       tmpDir+       (elaboratedPlanToExecute buildCtx)+       (elaboratedShared buildCtx)+       buildStatus+     action envOverrides)++pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath]+pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do+  info verbosity . unlines $ "Including the following directories in PATH:"+                           : paths+  return paths+  where+  paths = S.toList+        $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute++binDirectories+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedInstallPlan+  -> Set FilePath+binDirectories layout config = fromElaboratedInstallPlan where+  fromElaboratedInstallPlan = fromGraph . toGraph+  fromGraph = foldMap fromPlan+  fromSrcPkg = S.fromList . Planning.binDirectories layout config++  fromPlan (PreExisting _) = mempty+  fromPlan (Configured pkg) = fromSrcPkg pkg+  fromPlan (Installed pkg) = fromSrcPkg pkg+
+ src/Distribution/Client/CmdFreeze.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}++-- | cabal-install CLI command: freeze+--+module Distribution.Client.CmdFreeze (+    freezeCommand,+    freezeAction,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectPlanning+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..), ProjectConfigShared(..)+         , writeProjectLocalFreezeConfig )+import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos)+import Distribution.Client.Targets+         ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )+import Distribution.Solver.Types.PackageConstraint+         ( PackageProperty(..) )+import Distribution.Solver.Types.ConstraintSource+         ( ConstraintSource(..) )+import Distribution.Client.DistDirLayout+         ( DistDirLayout(distProjectFile) )+import qualified Distribution.Client.InstallPlan as InstallPlan+++import Distribution.Package+         ( PackageName, packageName, packageVersion )+import Distribution.Version+         ( VersionRange, thisVersion+         , unionVersionRanges, simplifyVersionRange )+import Distribution.PackageDescription+         ( FlagAssignment, nullFlagAssignment )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault )+import Distribution.Simple.Flag (Flag (..))+import Distribution.Simple.Utils+         ( die', notice, wrapText )+import Distribution.Verbosity+         ( normal )++import qualified Data.Map as Map++import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )++freezeCommand :: CommandUI (NixStyleFlags ())+freezeCommand = CommandUI {+  commandName         = "v2-freeze",+  commandSynopsis     = "Freeze dependencies.",+  commandUsage        = usageAlternatives "v2-freeze" [ "[FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "The project configuration is frozen so that it will be reproducible "+     ++ "in future.\n\n"++     ++ "The precise dependency configuration for the project is written to "+     ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "+     ++ "'--project-file' is specified). This file extends the configuration "+     ++ "from the 'cabal.project' file and thus is used as the project "+     ++ "configuration for all other commands (such as 'v2-build', "+     ++ "'v2-repl' etc).\n\n"++     ++ "The freeze file can be kept in source control. To make small "+     ++ "adjustments it may be edited manually, or to make bigger changes "+     ++ "you may wish to delete the file and re-freeze. For more control, "+     ++ "one approach is to try variations using 'v2-build --dry-run' with "+     ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "+     ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "+     ++ "with the same set of flags.",++  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " v2-freeze\n"+     ++ "    Freeze the configuration of the current project\n\n"+     ++ "  " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"+     ++ "    Check what a solution with the given constraints would look like\n"+     ++ "  " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n"+     ++ "    Freeze a solution using the given constraints\n"++   , commandDefaultFlags = defaultNixStyleFlags ()+   , commandOptions      = nixStyleOptions (const [])+   }++-- | To a first approximation, the @freeze@ command runs the first phase of+-- the @build@ command where we bring the install plan up to date, and then+-- based on the install plan we write out a @cabal.project.freeze@ config file.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do++    unless (null extraArgs) $+      die' verbosity $ "'freeze' doesn't take any extra arguments: "+         ++ unwords extraArgs++    ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages,+      buildSettings+    } <- establishProjectBaseContext verbosity cliConfig OtherCommand++    (_, elaboratedPlan, _, totalIndexState, activeRepos) <-+      rebuildInstallPlan verbosity+                         distDirLayout cabalDirLayout+                         projectConfig+                         localPackages++    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos+        dryRun = buildSettingDryRun buildSettings+              || buildSettingOnlyDownload buildSettings++    if dryRun+       then notice verbosity "Freeze file not written due to flag(s)"+       else do+         writeProjectLocalFreezeConfig distDirLayout freezeConfig+         notice verbosity $+           "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"++  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags+                  mempty -- ClientInstallFlags, not needed here++-- | Given the install plan, produce a config value with constraints that+-- freezes the versions of packages used in the plan.+--+projectFreezeConfig+    :: ElaboratedInstallPlan+    -> TotalIndexState+    -> ActiveRepos+    -> ProjectConfig+projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty+    { projectConfigShared = mempty+        { projectConfigConstraints =+          concat (Map.elems (projectFreezeConstraints elaboratedPlan))+        , projectConfigIndexState  = Flag totalIndexState+        , projectConfigActiveRepos = Flag activeRepos+        }+    }+  where+    activeRepos :: ActiveRepos+    activeRepos = filterSkippedActiveRepos activeRepos0++-- | Given the install plan, produce solver constraints that will ensure the+-- solver picks the same solution again in future in different environments.+--+projectFreezeConstraints :: ElaboratedInstallPlan+                         -> Map PackageName [(UserConstraint, ConstraintSource)]+projectFreezeConstraints plan =+    --+    -- TODO: [required eventually] this is currently an underapproximation+    -- since the constraints language is not expressive enough to specify the+    -- precise solution. See https://github.com/haskell/cabal/issues/3502.+    --+    -- For the moment we deal with multiple versions in the solution by using+    -- constraints that allow either version. Also, we do not include any+    -- /version/ constraints for packages that are local to the project (e.g.+    -- if the solution has two instances of Cabal, one from the local project+    -- and one pulled in as a setup deps then we exclude all constraints on+    -- Cabal, not just the constraint for the local instance since any+    -- constraint would apply to both instances). We do however keep flag+    -- constraints of local packages.+    --+    deleteLocalPackagesVersionConstraints+      (Map.unionWith (++) versionConstraints flagConstraints)+  where+    versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]+    versionConstraints =+      Map.mapWithKey+        (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v),+                   ConstraintSourceFreeze)])+        versionRanges++    versionRanges :: Map PackageName VersionRange+    versionRanges =+      Map.map simplifyVersionRange $+      Map.fromListWith unionVersionRanges $+          [ (packageName pkg, thisVersion (packageVersion pkg))+          | InstallPlan.PreExisting pkg <- InstallPlan.toList plan+          ]+       ++ [ (packageName pkg, thisVersion (packageVersion pkg))+          | InstallPlan.Configured pkg <- InstallPlan.toList plan+          ]++    flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]+    flagConstraints =+      Map.mapWithKey+        (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f),+                   ConstraintSourceFreeze)])+        flagAssignments++    flagAssignments :: Map PackageName FlagAssignment+    flagAssignments =+      Map.fromList+        [ (pkgname, flags)+        | InstallPlan.Configured elab <- InstallPlan.toList plan+        , let flags   = elabFlagAssignment elab+              pkgname = packageName elab+        , not (nullFlagAssignment flags) ]++    -- As described above, remove the version constraints on local packages,+    -- but leave any flag constraints.+    deleteLocalPackagesVersionConstraints+      :: Map PackageName [(UserConstraint, ConstraintSource)]+      -> Map PackageName [(UserConstraint, ConstraintSource)]+    deleteLocalPackagesVersionConstraints =+      Map.mergeWithKey+        (\_pkgname () constraints ->+            case filter (not . isVersionConstraint . fst) constraints of+              []           -> Nothing+              constraints' -> Just constraints')+        (const Map.empty) id+        localPackages++    isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True+    isVersionConstraint _                                             = False++    localPackages :: Map PackageName ()+    localPackages =+      Map.fromList+        [ (packageName elab, ())+        | InstallPlan.Configured elab <- InstallPlan.toList plan+        , elabLocalToProject elab+        ]+
+ src/Distribution/Client/CmdHaddock.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE RecordWildCards #-}++-- | cabal-install CLI command: haddock+--+module Distribution.Client.CmdHaddock (+    -- * The @haddock@ CLI and action+    haddockCommand,+    haddockAction,++    -- * Internals exposed for testing+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages+import Distribution.Client.TargetProblem+         ( TargetProblem (..), TargetProblem' )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..) )+import Distribution.Simple.Setup+         ( HaddockFlags(..), fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Verbosity+         ( normal )+import Distribution.Simple.Utils+         ( wrapText, die' )++haddockCommand :: CommandUI (NixStyleFlags ())+haddockCommand = CommandUI {+  commandName         = "v2-haddock",+  commandSynopsis     = "Build Haddock documentation",+  commandUsage        = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Build Haddock documentation for the specified packages within the "+     ++ "project.\n\n"++     ++ "Any package in the project can be specified. If no package is "+     ++ "specified, the default is to build the documentation for the package "+     ++ "in the current directory. The default behaviour is to build "+     ++ "documentation for the exposed modules of the library component (if "+     ++ "any). This can be changed with the '--internal', '--executables', "+     ++ "'--tests', '--benchmarks' or '--all' flags.\n\n"++     ++ "Currently, documentation for dependencies is NOT built. This "+     ++ "behavior may change in future.\n\n"++     ++ "Additional configuration flags can be specified on the command line "+     ++ "and these extend the project configuration from the 'cabal.project', "+     ++ "'cabal.project.local' and other files.",+  commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " v2-haddock pkgname"+     ++ "    Build documentation for the package named pkgname\n"+  , commandOptions      = nixStyleOptions (const [])+  , commandDefaultFlags = defaultNixStyleFlags ()+  }+   --TODO: [nice to have] support haddock on specific components, not just+   -- whole packages and the silly --executables etc modifiers.++-- | The @haddock@ command is TODO.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+haddockAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do+    baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do++            when (buildSettingOnlyDeps (buildSettings baseCtx)) $+              die' verbosity+                "The haddock command does not support '--only-dependencies'."++              -- When we interpret the targets on the command line, interpret them as+              -- haddock targets+            targets <- either (reportBuildDocumentationTargetProblems verbosity) return+                     $ resolveTargets+                         (selectPackageTargets haddockFlags)+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionHaddock+                                    targets+                                    elaboratedPlan+            return (elaboratedPlan', targets)++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here++-- | This defines what a 'TargetSelector' means for the @haddock@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @haddock@ command we select all buildable libraries. Additionally,+-- depending on the @--executables@ flag we also select all the buildable exes.+-- We do similarly for test-suites, benchmarks and foreign libs.+--+selectPackageTargets  :: HaddockFlags -> TargetSelector+                      -> [AvailableTarget k] -> Either TargetProblem' [k]+selectPackageTargets haddockFlags targetSelector targets++    -- If there are any buildable targets then we select those+  | not (null targetsBuildable)+  = Right targetsBuildable++    -- If there are targets but none are buildable then we report those+  | not (null targets)+  = Left (TargetProblemNoneEnabled targetSelector targets')++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targets'         = forgetTargetsDetail    (map disableNotRequested targets)+    targetsBuildable = selectBuildableTargets (map disableNotRequested targets)++    -- When there's a target filter like "pkg:exes" then we do select exes,+    -- but if it's just a target like "pkg" then we don't build docs for exes+    -- unless they are requested by default (i.e. by using --executables)+    disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _)+      | not (isRequested targetSelector (componentKind cname))+      = t { availableTargetStatus = TargetDisabledByUser }+    disableNotRequested t = t++    isRequested (TargetPackage _ _ (Just _)) _ = True+    isRequested (TargetAllPackages (Just _)) _ = True+    isRequested _ LibKind    = True+--  isRequested _ SubLibKind = True --TODO: what about sublibs?++    -- TODO/HACK, we encode some defaults here as v2-haddock's logic;+    -- make sure this matches the defaults applied in+    -- "Distribution.Client.ProjectPlanning"; this may need more work+    -- to be done properly+    --+    -- See also https://github.com/haskell/cabal/pull/4886+    isRequested _ FLibKind   = fromFlagOrDefault False (haddockForeignLibs haddockFlags)+    isRequested _ ExeKind    = fromFlagOrDefault False (haddockExecutables haddockFlags)+    isRequested _ TestKind   = fromFlagOrDefault False (haddockTestSuites  haddockFlags)+    isRequested _ BenchKind  = fromFlagOrDefault False (haddockBenchmarks  haddockFlags)+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @haddock@ command we just need the basic checks on being buildable+-- etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either TargetProblem' k+selectComponentTarget = selectComponentTargetBasic++reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a+reportBuildDocumentationTargetProblems verbosity problems =+  reportTargetProblems verbosity "build documentation for" problems
+ src/Distribution/Client/CmdInstall.hs view
@@ -0,0 +1,965 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | cabal-install CLI command: build+--+module Distribution.Client.CmdInstall (+    -- * The @build@ CLI and action+    installCommand,+    installAction,++    -- * Internals exposed for testing+    selectPackageTargets,+    selectComponentTarget,+    -- * Internals exposed for CmdRepl + CmdRun+    establishDummyDistDirLayout,+    establishDummyProjectBaseContext+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+import Distribution.Compat.Directory+         ( doesPathExist )++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages+import Distribution.Client.CmdSdist+import Distribution.Client.TargetProblem+         ( TargetProblem', TargetProblem (..) )++import Distribution.Client.CmdInstall.ClientInstallFlags+import Distribution.Client.CmdInstall.ClientInstallTargetSelector++import Distribution.Client.Setup+         ( GlobalFlags(..), ConfigFlags(..) )+import Distribution.Client.Types+         ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage+         , SourcePackageDb(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Package+         ( Package(..), PackageName, mkPackageName, unPackageName )+import Distribution.Types.PackageId+         ( PackageIdentifier(..) )+import Distribution.Client.ProjectConfig+         ( ProjectPackageLocation(..)+         , fetchAndReadSourcePackages+         , projectConfigWithBuilderRepoContext+         , resolveBuildTimeSettings, withProjectOrGlobalConfig )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.ProjectFlags (ProjectFlags (..))+import Distribution.Client.ProjectConfig.Types+         ( ProjectConfig(..), ProjectConfigShared(..)+         , ProjectConfigBuildOnly(..), PackageConfig(..)+         , getMapLast, getMapMappend, projectConfigLogsDir+         , projectConfigStoreDir, projectConfigBuildOnly+         , projectConfigConfigFile )+import Distribution.Simple.Program.Db+         ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb+         , modifyProgramSearchPath, ProgramDb )+import Distribution.Simple.BuildPaths+         ( exeExtension )+import Distribution.Simple.Program.Find+         ( ProgramSearchPathEntry(..) )+import Distribution.Client.Config+         ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) )+import qualified Distribution.Simple.PackageIndex as PI+import Distribution.Solver.Types.PackageIndex+         ( lookupPackageName, searchByName )+import Distribution.Types.InstalledPackageInfo+         ( InstalledPackageInfo(..) )+import Distribution.Types.Version+         ( Version, nullVersion )+import Distribution.Types.VersionRange+         ( thisVersion )+import Distribution.Solver.Types.PackageConstraint+         ( PackageProperty(..) )+import Distribution.Client.IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.ProjectPlanning+         ( storePackageInstallDirs' )+import Distribution.Client.ProjectPlanning.Types+         ( ElaboratedInstallPlan )+import qualified Distribution.Simple.InstallDirs as InstallDirs+import Distribution.Client.DistDirLayout+         ( DistDirLayout(..), mkCabalDirLayout+         , cabalStoreDirLayout+         , CabalDirLayout(..), StoreDirLayout(..) )+import Distribution.Client.RebuildMonad+         ( runRebuild )+import Distribution.Client.InstallSymlink+         ( symlinkBinary, trySymlink )+import Distribution.Client.Types.OverwritePolicy+         ( OverwritePolicy (..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault, flagToMaybe, flagElim )+import Distribution.Simple.Setup+         ( Flag(..) )+import Distribution.Solver.Types.SourcePackage+         ( SourcePackage(..) )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Configure+         ( configCompilerEx )+import Distribution.Simple.Compiler+         ( Compiler(..), CompilerId(..), CompilerFlavor(..)+         , PackageDBStack )+import Distribution.Simple.GHC+         ( ghcPlatformAndVersionString, getGhcAppDir+         , GhcImplInfo(..), getImplInfo+         , GhcEnvironmentFileEntry(..)+         , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )+import Distribution.System+         ( Platform , buildOS, OS (Windows) )+import Distribution.Types.UnitId+         ( UnitId )+import Distribution.Types.UnqualComponentName+         ( UnqualComponentName, unUnqualComponentName )+import Distribution.Verbosity+         ( normal, lessVerbose )+import Distribution.Simple.Utils+         ( wrapText, die', notice, warn+         , withTempDirectory, createDirectoryIfMissingVerbose+         , ordNub )+import Distribution.Utils.Generic+         ( safeHead, writeFileAtomic )++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.Ord+         ( Down(..) )+import qualified Data.Map as Map+import Distribution.Utils.NubList+         ( fromNubList )+import Network.URI (URI)+import System.Directory+         ( doesFileExist, createDirectoryIfMissing+         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist+         , removeFile, removeDirectory, copyFile )+import System.FilePath+         ( (</>), (<.>), takeDirectory, takeBaseName )++installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)+installCommand = CommandUI+  { commandName         = "v2-install"+  , commandSynopsis     = "Install packages."+  , commandUsage        = usageAlternatives+                          "v2-install" [ "[TARGETS] [FLAGS]" ]+  , commandDescription  = Just $ \_ -> wrapText $+    "Installs one or more packages. This is done by installing them "+    ++ "in the store and symlinking/copying the executables in the directory "+    ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). "+    ++ "If you want the installed executables to be available globally, "+    ++ "make sure that the PATH environment variable contains that directory. "+    ++ "\n\n"+    ++ "If TARGET is a library and --lib (provisional) is used, "+    ++ "it will be added to the global environment. "+    ++ "When doing this, cabal will try to build a plan that includes all "+    ++ "the previously installed libraries. This is currently not implemented."+  , commandNotes        = Just $ \pname ->+      "Examples:\n"+      ++ "  " ++ pname ++ " v2-install\n"+      ++ "    Install the package in the current directory\n"+      ++ "  " ++ pname ++ " v2-install pkgname\n"+      ++ "    Install the package named pkgname"+      ++ " (fetching it from hackage if necessary)\n"+      ++ "  " ++ pname ++ " v2-install ./pkgfoo\n"+      ++ "    Install the package in the ./pkgfoo directory\n"++  , commandOptions      = nixStyleOptions clientInstallOptions+  , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags+  }++-- | The @install@ command actually serves four different needs. It installs:+-- * exes:+--   For example a program from hackage. The behavior is similar to the old+--   install command, except that now conflicts between separate runs of the+--   command are impossible thanks to the store.+--   Exes are installed in the store like a normal dependency, then they are+--   symlinked/copied in the directory specified by --installdir.+--   To do this we need a dummy projectBaseContext containing the targets as+--   estra packages and using a temporary dist directory.+-- * libraries+--   Libraries install through a similar process, but using GHC environment+--   files instead of symlinks. This means that 'v2-install'ing libraries+--   only works on GHC >= 8.0.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()+installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do+  -- Ensure there were no invalid configuration options specified.+  verifyPreconditionsOrDie verbosity configFlags'++  -- We cannot use establishDummyProjectBaseContext to get these flags, since+  -- it requires one of them as an argument. Normal establishProjectBaseContext+  -- does not, and this is why this is done only for the install command+  clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'++  let+    installLibs    = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)+    targetFilter   = if installLibs then Just LibKind else Just ExeKind+    targetStrings' = if null targetStrings then ["."] else targetStrings++    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)+    withProject = do+      let reducedVerbosity = lessVerbose verbosity++      -- First, we need to learn about what's available to be installed.+      localBaseCtx <-+        establishProjectBaseContext reducedVerbosity cliConfig InstallCommand+      let localDistDirLayout = distDirLayout localBaseCtx+      pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity+               (buildSettings localBaseCtx) (getSourcePackages verbosity)++      let+        (targetStrings'', packageIds) =+          partitionEithers .+          flip fmap targetStrings' $+          \str -> case simpleParsec str of+            Just (pkgId :: PackageId)+              | pkgVersion pkgId /= nullVersion -> Right pkgId+            _                                   -> Left str+        packageSpecifiers =+          flip fmap packageIds $ \case+          PackageIdentifier{..}+            | pkgVersion == nullVersion -> NamedPackage pkgName []+            | otherwise                 -> NamedPackage pkgName+                                           [PackagePropertyVersion+                                            (thisVersion pkgVersion)]+        packageTargets =+          flip TargetPackageNamed targetFilter . pkgName <$> packageIds++      if null targetStrings'+        then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)+        else do+          targetSelectors <-+            either (reportTargetSelectorProblems verbosity) return+            =<< readTargetSelectors (localPackages localBaseCtx)+                                    Nothing targetStrings''++          (specs, selectors) <-+            getSpecsAndTargetSelectors+              verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter++          return ( specs ++ packageSpecifiers+                 , []+                 , selectors ++ packageTargets+                 , projectConfig localBaseCtx )++    withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)+    withoutProject globalConfig = do+      tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'++      cabalDir <- getCabalDir+      let+        projectConfig = globalConfig <> cliConfig++        ProjectConfigBuildOnly {+          projectConfigLogsDir+        } = projectConfigBuildOnly projectConfig++        ProjectConfigShared {+          projectConfigStoreDir+        } = projectConfigShared projectConfig++        mlogsDir = flagToMaybe projectConfigLogsDir+        mstoreDir = flagToMaybe projectConfigStoreDir+        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir++        buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++      SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext+                                            verbosity buildSettings+                                            (getSourcePackages verbosity)++      for_ (concatMap woPackageNames tss) $ \name -> do+        when (null (lookupPackageName packageIndex name)) $ do+          let xs = searchByName packageIndex (unPackageName name)+          let emptyIf True  _  = []+              emptyIf False zs = zs+          die' verbosity $ concat $+            [ "Unknown package \"", unPackageName name, "\". "+            ] ++ emptyIf (null xs)+            [ "Did you mean any of the following?\n"+            , unlines (("- " ++) . unPackageName . fst <$> xs)+            ]++      let+        (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss+        packageTargets            = map woPackageTargets tss++      return (packageSpecifiers, uris, packageTargets, projectConfig)++  (specs, uris, targetSelectors, config) <-+     withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject++  let+    ProjectConfig {+      projectConfigBuildOnly = ProjectConfigBuildOnly {+        projectConfigLogsDir+      },+      projectConfigShared = ProjectConfigShared {+        projectConfigHcFlavor,+        projectConfigHcPath,+        projectConfigHcPkg,+        projectConfigStoreDir+      },+      projectConfigLocalPackages = PackageConfig {+        packageConfigProgramPaths,+        packageConfigProgramArgs,+        packageConfigProgramPathExtra+      }+    } = config++    hcFlavor = flagToMaybe projectConfigHcFlavor+    hcPath   = flagToMaybe projectConfigHcPath+    hcPkg    = flagToMaybe projectConfigHcPkg++    -- ProgramDb with directly user specified paths+    preProgDb =+        userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))+      . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))+      . modifyProgramSearchPath+          (++ [ ProgramSearchPathDir dir+              | dir <- fromNubList packageConfigProgramPathExtra ])+      $ defaultProgramDb++  -- progDb is a program database with compiler tools configured properly+  (compiler@Compiler { compilerId =+    compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <-+      configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity++  let+    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler++  envFile <- getEnvFile clientInstallFlags platform compilerVersion+  existingEnvEntries <-+    getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile+  packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir+  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb++  let+    (envSpecs, nonGlobalEnvEntries) =+      getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs++  -- Second, we need to use a fake project to let Cabal build the+  -- installables correctly. For that, we need a place to put a+  -- temporary dist directory.+  globalTmp <- getTemporaryDirectory++  withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do+    distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir++    uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages+      verbosity+      distDirLayout+      (projectConfigShared config)+      (projectConfigBuildOnly config)+      [ ProjectPackageRemoteTarball uri | uri <- uris ]++    baseCtx <- establishDummyProjectBaseContext+                 verbosity+                 config+                 distDirLayout+                 (envSpecs ++ specs ++ uriSpecs)+                 InstallCommand++    buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes++    -- Now that we built everything we can do the installation part.+    -- First, figure out if / what parts we want to install:+    let+      dryRun = buildSettingDryRun (buildSettings baseCtx)+            || buildSettingOnlyDownload (buildSettings baseCtx)++    -- Then, install!+    unless dryRun $+      if installLibs+      then installLibraries verbosity+           buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries+      else installExes verbosity+           baseCtx buildCtx platform compiler configFlags clientInstallFlags+  where+    configFlags' = disableTestsBenchsByDefault configFlags+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')+    ignoreProject = flagIgnoreProject projectFlags+    cliConfig = commandLineFlagsToProjectConfig+                  globalFlags+                  flags { configFlags = configFlags' }+                  clientInstallFlags'+    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)++-- | Verify that invalid config options were not passed to the install command.+--+-- If an invalid configuration is found the command will @die'@.+verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()+verifyPreconditionsOrDie verbosity configFlags = do+  -- We never try to build tests/benchmarks for remote packages.+  -- So we set them as disabled by default and error if they are explicitly+  -- enabled.+  when (configTests configFlags == Flag True) $+    die' verbosity $ "--enable-tests was specified, but tests can't "+                  ++ "be enabled in a remote package"+  when (configBenchmarks configFlags == Flag True) $+    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "+                  ++ "be enabled in a remote package"++getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags+getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do+  let configFileFlag = globalConfigFile globalFlags+  savedConfig <- loadConfig verbosity configFileFlag+  pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags+++getSpecsAndTargetSelectors+  :: Verbosity+  -> Verbosity+  -> SourcePackageDb+  -> [TargetSelector]+  -> DistDirLayout+  -> ProjectBaseContext+  -> Maybe ComponentKindFilter+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])+getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =+  withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do+  -- Split into known targets and hackage packages.+  (targets, hackageNames) <-+    partitionToKnownTargetsAndHackagePackages+      verbosity pkgDb elaboratedPlan targetSelectors++  let+    planMap = InstallPlan.toMap elaboratedPlan+    targetIds = Map.keys targets++    sdistize (SpecificSourcePackage spkg) =+      SpecificSourcePackage spkg'+      where+        sdistPath = distSdistFile localDistDirLayout (packageId spkg)+        spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath }+    sdistize named = named++    local = sdistize <$> localPackages localBaseCtx++    gatherTargets :: UnitId -> TargetSelector+    gatherTargets targetId = TargetPackageNamed pkgName targetFilter+      where+        targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap+        PackageIdentifier{..} = packageId targetUnit++    targets' = fmap gatherTargets targetIds++    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]+    hackagePkgs = flip NamedPackage [] <$> hackageNames++    hackageTargets :: [TargetSelector]+    hackageTargets =+      flip TargetPackageNamed targetFilter <$> hackageNames++  createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)++  unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of+      SpecificSourcePackage pkg -> packageToSdist verbosity+        (distProjectRootDirectory localDistDirLayout) TarGzArchive+        (distSdistFile localDistDirLayout (packageId pkg)) pkg+      NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName++  if null targets+    then return (hackagePkgs, hackageTargets)+    else return (local ++ hackagePkgs, targets' ++ hackageTargets)++-- | Partitions the target selectors into known local targets and hackage packages.+partitionToKnownTargetsAndHackagePackages+  :: Verbosity+  -> SourcePackageDb+  -> ElaboratedInstallPlan+  -> [TargetSelector]+  -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName])+partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do+  let mTargets = resolveTargets+        selectPackageTargets+        selectComponentTarget+        elaboratedPlan+        (Just pkgDb)+        targetSelectors+  case mTargets of+    Right targets ->+      -- Everything is a local dependency.+      return (targets, [])+    Left errs     -> do+      -- Not everything is local.+      let+        (errs', hackageNames) = partitionEithers . flip fmap errs $ \case+          TargetAvailableInIndex name -> Right name+          err                         -> Left err++      -- report incorrect case for known package.+      for_ errs' $ \case+        TargetNotInProject hn ->+          case searchByName (packageIndex pkgDb) (unPackageName hn) of+            [] -> return ()+            xs -> die' verbosity . concat $+              [ "Unknown package \"", unPackageName hn, "\". "+              , "Did you mean any of the following?\n"+              , unlines (("- " ++) . unPackageName . fst <$> xs)+              ]+        _ -> return ()++      when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'++      let+        targetSelectors' = flip filter targetSelectors $ \case+          TargetComponentUnknown name _ _+            | name `elem` hackageNames -> False+          TargetPackageNamed name _+            | name `elem` hackageNames -> False+          _                            -> True++      -- This can't fail, because all of the errors are+      -- removed (or we've given up).+      targets <-+        either (reportBuildTargetProblems verbosity) return $+        resolveTargets+          selectPackageTargets+          selectComponentTarget+          elaboratedPlan+          Nothing+          targetSelectors'++      return (targets, hackageNames)++++constructProjectBuildContext+  :: Verbosity+  -> ProjectBaseContext+     -- ^ The synthetic base context to use to produce the full build context.+  -> [TargetSelector]+  -> IO ProjectBuildContext+constructProjectBuildContext verbosity baseCtx targetSelectors = do+  runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do+    -- Interpret the targets on the command line as build targets+    targets <- either (reportBuildTargetProblems verbosity) return $+      resolveTargets+        selectPackageTargets+        selectComponentTarget+        elaboratedPlan+        Nothing+        targetSelectors++    let prunedToTargetsElaboratedPlan =+          pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan+    prunedElaboratedPlan <-+      if buildSettingOnlyDeps (buildSettings baseCtx)+      then either (reportCannotPruneDependencies verbosity) return $+           pruneInstallPlanToDependencies (Map.keysSet targets)+                                          prunedToTargetsElaboratedPlan+      else return prunedToTargetsElaboratedPlan++    return (prunedElaboratedPlan, targets)+++-- | Install any built exe by symlinking/copying it+-- we don't use BuildOutcomes because we also need the component names+installExes+  :: Verbosity+  -> ProjectBaseContext+  -> ProjectBuildContext+  -> Platform+  -> Compiler+  -> ConfigFlags+  -> ClientInstallFlags+  -> IO ()+installExes verbosity baseCtx buildCtx platform compiler+            configFlags clientInstallFlags = do+  installPath <- defaultInstallPath+  let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx++      prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))+      suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))++      mkUnitBinDir :: UnitId -> FilePath+      mkUnitBinDir =+        InstallDirs.bindir .+        storePackageInstallDirs' storeDirLayout (compilerId compiler)++      mkExeName :: UnqualComponentName -> FilePath+      mkExeName exe = unUnqualComponentName exe <.> exeExtension platform++      mkFinalExeName :: UnqualComponentName -> FilePath+      mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform+      installdirUnknown =+        "installdir is not defined. Set it in your cabal config file "+        ++ "or use --installdir=<path>. Using default installdir: " ++ show installPath++  installdir <- fromFlagOrDefault+                (warn verbosity installdirUnknown >> pure installPath) $+                pure <$> cinstInstalldir clientInstallFlags+  createDirectoryIfMissingVerbose verbosity False installdir+  warnIfNoExes verbosity buildCtx++  installMethod <- flagElim defaultMethod return $+    cinstInstallMethod clientInstallFlags++  let+    doInstall = installUnitExes+                  verbosity+                  overwritePolicy+                  mkUnitBinDir mkExeName mkFinalExeName+                  installdir installMethod+    in traverse_ doInstall $ Map.toList $ targetsMap buildCtx+  where+    overwritePolicy = fromFlagOrDefault NeverOverwrite $+                      cinstOverwritePolicy clientInstallFlags+    isWindows = buildOS == Windows++    -- This is in IO as we will make environment checks,+    -- to decide which method is best+    defaultMethod :: IO InstallMethod+    defaultMethod+      -- Try symlinking in temporary directory, if it works default to+      -- symlinking even on windows+      | isWindows = do+        symlinks <- trySymlink verbosity+        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy+      | otherwise = return InstallMethodSymlink++-- | Install any built library by adding it to the default ghc environment+installLibraries+  :: Verbosity+  -> ProjectBuildContext+  -> Compiler+  -> PackageDBStack+  -> ProgramDb+  -> FilePath -- ^ Environment file+  -> [GhcEnvironmentFileEntry]+  -> IO ()+installLibraries verbosity buildCtx compiler+                 packageDbs programDb envFile envEntries = do+  -- Why do we get it again? If we updated a globalPackage then we need+  -- the new version.+  installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb+  if supportsPkgEnvFiles $ getImplInfo compiler+    then do+      let+        getLatest :: PackageName -> [InstalledPackageInfo]+        getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst))+                  . PI.lookupPackageName installedIndex+        globalLatest = concat (getLatest <$> globalPackages)++        baseEntries =+          GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs+        globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest+        pkgEntries = ordNub $+              globalEntries+          ++ envEntries+          ++ entriesForLibraryComponents (targetsMap buildCtx)+        contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)+      createDirectoryIfMissing True (takeDirectory envFile)+      writeFileAtomic envFile (BS.pack contents')+    else+      warn verbosity $+          "The current compiler doesn't support safely installing libraries, "+        ++ "so only executables will be available. (Library installation is "+        ++ "supported on GHC 8.0+ only)"++warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()+warnIfNoExes verbosity buildCtx =+  when noExes $+    warn verbosity $+    "\n" <>+    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>+    "@ WARNING: Installation might not be completed as desired! @\n" <>+    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>+    "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <>+    "* You might have wanted to add them as dependencies to your package." <>+    " In this case add \"" <>+    intercalate ", " (showTargetSelector <$> selectors) <>+    "\" to the build-depends field(s) of your package's .cabal file.\n" <>+    "* You might have wanted to add them to a GHC environment. In this case" <>+    " use \"cabal install --lib " <>+    unwords (showTargetSelector <$> selectors) <> "\". " <>+    " The \"--lib\" flag is provisional: see" <>+    " https://github.com/haskell/cabal/issues/6481 for more information."+  where+    targets    = concat $ Map.elems $ targetsMap buildCtx+    components = fst <$> targets+    selectors  = concatMap snd targets+    noExes     = null $ catMaybes $ exeMaybe <$> components++    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe+    exeMaybe _                                  = Nothing++globalPackages :: [PackageName]+globalPackages = mkPackageName <$>+  [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath"+  , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary"+  , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq"+  , "ghc-boot-th", "pretty", "template-haskell", "directory", "text"+  , "bin-package-db"+  ]++-- | Return the package specifiers and non-global environment file entries.+getEnvSpecsAndNonGlobalEntries+  :: PI.InstalledPackageIndex+  -> [GhcEnvironmentFileEntry]+  -> Bool+  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])+getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =+  if installLibs+  then (envSpecs, envEntries')+  else ([], envEntries')+  where+    (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries++environmentFileToSpecifiers+  :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]+  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])+environmentFileToSpecifiers ipi = foldMap $ \case+    (GhcEnvFilePackageId unitId)+        | Just InstalledPackageInfo+          { sourcePackageId = PackageIdentifier{..}, installedUnitId }+          <- PI.lookupUnitId ipi unitId+        , let pkgSpec = NamedPackage pkgName+                        [PackagePropertyVersion (thisVersion pkgVersion)]+        -> if pkgName `elem` globalPackages+          then ([pkgSpec], [])+          else ([pkgSpec], [GhcEnvFilePackageId installedUnitId])+    _ -> ([], [])+++-- | Disables tests and benchmarks if they weren't explicitly enabled.+disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags+disableTestsBenchsByDefault configFlags =+  configFlags { configTests = Flag False <> configTests configFlags+              , configBenchmarks = Flag False <> configBenchmarks configFlags }++-- | Symlink/copy every exe from a package from the store to a given location+installUnitExes+  :: Verbosity+  -> OverwritePolicy -- ^ Whether to overwrite existing files+  -> (UnitId -> FilePath) -- ^ A function to get an UnitId's+                          -- ^ store directory+  -> (UnqualComponentName -> FilePath) -- ^ A function to get an+                                       -- ^ exe's filename+  -> (UnqualComponentName -> FilePath) -- ^ A function to get an+                                       -- ^ exe's final possibly+                                       -- ^ different to the name in the store.+  -> FilePath+  -> InstallMethod+  -> ( UnitId+     , [(ComponentTarget, [TargetSelector])] )+  -> IO ()+installUnitExes verbosity overwritePolicy+                mkSourceBinDir mkExeName mkFinalExeName+                installdir installMethod+                (unit, components) =+  traverse_ installAndWarn exes+  where+    exes = catMaybes $ (exeMaybe . fst) <$> components+    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe+    exeMaybe _ = Nothing+    installAndWarn exe = do+      success <- installBuiltExe+                   verbosity overwritePolicy+                   (mkSourceBinDir unit) (mkExeName exe)+                   (mkFinalExeName exe)+                   installdir installMethod+      let errorMessage = case overwritePolicy of+            NeverOverwrite ->+              "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "+              <> "Use --overwrite-policy=always to overwrite."+            -- This shouldn't even be possible, but we keep it in case+            -- symlinking/copying logic changes+            AlwaysOverwrite ->+              case installMethod of+                InstallMethodSymlink -> "Symlinking"+                InstallMethodCopy    ->+                  "Copying" <> " '" <> prettyShow exe <> "' failed."+      unless success $ die' verbosity errorMessage++-- | Install a specific exe.+installBuiltExe+  :: Verbosity -> OverwritePolicy+  -> FilePath -- ^ The directory where the built exe is located+  -> FilePath -- ^ The exe's filename+  -> FilePath -- ^ The exe's filename in the public install directory+  -> FilePath -- ^ the directory where it should be installed+  -> InstallMethod+  -> IO Bool -- ^ Whether the installation was successful+installBuiltExe verbosity overwritePolicy+                sourceDir exeName finalExeName+                installdir InstallMethodSymlink = do+  notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"+  symlinkBinary+    overwritePolicy+    installdir+    sourceDir+    finalExeName+    exeName+  where+    destination = installdir </> finalExeName+installBuiltExe verbosity overwritePolicy+                sourceDir exeName finalExeName+                installdir InstallMethodCopy = do+  notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"+  exists <- doesPathExist destination+  case (exists, overwritePolicy) of+    (True , NeverOverwrite ) -> pure False+    (True , AlwaysOverwrite) -> remove >> copy+    (False, _              ) -> copy+  where+    source      = sourceDir </> exeName+    destination = installdir </> finalExeName+    remove = do+      isDir <- doesDirectoryExist destination+      if isDir+      then removeDirectory destination+      else removeFile      destination+    copy = copyFile source destination >> pure True++-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.+entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]+entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []+  where+    hasLib :: (ComponentTarget, [TargetSelector]) -> Bool+    hasLib (ComponentTarget (CLibName _) _, _) = True+    hasLib _                                   = False++    go :: UnitId+       -> [(ComponentTarget, [TargetSelector])]+       -> [GhcEnvironmentFileEntry]+    go unitId targets+      | any hasLib targets = [GhcEnvFilePackageId unitId]+      | otherwise          = []+++-- | Gets the file path to the request environment file.+getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath+getEnvFile clientInstallFlags platform compilerVersion = do+  appDir <- getGhcAppDir+  case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of+    Just spec+      -- Is spec a bare word without any "pathy" content, then it refers to+      -- a named global environment.+      | takeBaseName spec == spec ->+          return (getGlobalEnv appDir platform compilerVersion spec)+      | otherwise                 -> do+        spec' <- makeAbsolute spec+        isDir <- doesDirectoryExist spec'+        if isDir+          -- If spec is a directory, then make an ambient environment inside+          -- that directory.+          then return (getLocalEnv spec' platform compilerVersion)+          -- Otherwise, treat it like a literal file path.+          else return spec'+    Nothing                       ->+      return (getGlobalEnv appDir platform compilerVersion "default")++-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the+--   environment being operated on.+getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]+getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do+  envFileExists <- doesFileExist envFile+  filterEnvEntries <$> if+    (compilerFlavor == GHC || compilerFlavor == GHCJS)+      && supportsPkgEnvFiles && envFileExists+    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->+      warn verbosity ("The environment file " ++ envFile +++        " is unparsable. Libraries cannot be installed.") >> return []+    else return []+  where+    -- Why? We know what the first part will be, we only care about the packages.+    filterEnvEntries = filter $ \case+      GhcEnvFilePackageId _ -> True+      _                     -> False++-- | Constructs the path to the global GHC environment file.+--+-- TODO(m-renaud): Create PkgEnvName newtype wrapper.+getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath+getGlobalEnv appDir platform compilerVersion name =+  appDir </> ghcPlatformAndVersionString platform compilerVersion+  </> "environments" </> name++-- | Constructs the path to a local GHC environment file.+getLocalEnv :: FilePath -> Platform -> Version -> FilePath+getLocalEnv dir platform compilerVersion  =+  dir </>+  ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion++getPackageDbStack+  :: CompilerId+  -> Flag FilePath+  -> Flag FilePath+  -> IO PackageDBStack+getPackageDbStack compilerId storeDirFlag logsDirFlag = do+  cabalDir <- getCabalDir+  mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag+  let+    mlogsDir    = flagToMaybe logsDirFlag+    cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir+  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId++-- | This defines what a 'TargetSelector' means for the @bench@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @build@ command select all components except non-buildable+-- and disabled tests\/benchmarks, fail if there are no such+-- components+--+selectPackageTargets+  :: TargetSelector+  -> [AvailableTarget k] -> Either TargetProblem' [k]+selectPackageTargets targetSelector targets++    -- If there are any buildable targets then we select those+  | not (null targetsBuildable)+  = Right targetsBuildable++    -- If there are targets but none are buildable then we report those+  | not (null targets)+  = Left (TargetProblemNoneEnabled targetSelector targets')++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targets'         = forgetTargetsDetail targets+    targetsBuildable = selectBuildableTargetsWith+                         (buildable targetSelector)+                         targets++    -- When there's a target filter like "pkg:tests" then we do select tests,+    -- but if it's just a target like "pkg" then we don't build tests unless+    -- they are requested by default (i.e. by using --enable-tests)+    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False+    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False+    buildable _ _ = True++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @build@ command we just need the basic checks on being buildable etc.+--+selectComponentTarget+  :: SubComponentTarget+  -> AvailableTarget k -> Either TargetProblem' k+selectComponentTarget = selectComponentTargetBasic++reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a+reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems++reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a+reportCannotPruneDependencies verbosity =+    die' verbosity . renderCannotPruneDependencies
+ src/Distribution/Client/CmdInstall/ClientInstallFlags.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+module Distribution.Client.CmdInstall.ClientInstallFlags+( InstallMethod(..)+, ClientInstallFlags(..)+, defaultClientInstallFlags+, clientInstallOptions+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.ReadE+         ( succeedReadE, parsecToReadE )+import Distribution.Simple.Command+         ( ShowOrParseArgs(..), OptionField(..), option, reqArg )+import Distribution.Simple.Setup+         ( Flag(..), trueArg, flagToList, toFlag )++import Distribution.Client.Types.InstallMethod+         ( InstallMethod (..) )+import Distribution.Client.Types.OverwritePolicy+         ( OverwritePolicy(..) )++import qualified Distribution.Compat.CharParsing as P++data ClientInstallFlags = ClientInstallFlags+  { cinstInstallLibs     :: Flag Bool+  , cinstEnvironmentPath :: Flag FilePath+  , cinstOverwritePolicy :: Flag OverwritePolicy+  , cinstInstallMethod   :: Flag InstallMethod+  , cinstInstalldir      :: Flag FilePath+  } deriving (Eq, Show, Generic)++instance Monoid ClientInstallFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ClientInstallFlags where+  (<>) = gmappend++instance Binary ClientInstallFlags+instance Structured ClientInstallFlags++defaultClientInstallFlags :: ClientInstallFlags+defaultClientInstallFlags = ClientInstallFlags+  { cinstInstallLibs     = toFlag False+  , cinstEnvironmentPath = mempty+  , cinstOverwritePolicy = mempty+  , cinstInstallMethod   = mempty+  , cinstInstalldir      = mempty+  }++clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]+clientInstallOptions _ =+  [ option [] ["lib"]+    ( "Install libraries rather than executables from the target package " <>+      "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." )+    cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v })+    trueArg+  , option [] ["package-env", "env"]+    "Set the environment file that may be modified."+    cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })+    (reqArg "ENV" (succeedReadE Flag) flagToList)+  , option [] ["overwrite-policy"]+    "How to handle already existing symlinks."+    cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })+    $ reqArg "always|never"+        (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) +        (map prettyShow . flagToList)+  , option [] ["install-method"]+    "How to install the executables."+    cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })+    $ reqArg+        "default|copy|symlink"+        (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod))+        (map prettyShow . flagToList)+  , option [] ["installdir"]+    "Where to install (by symlinking or copying) the executables in."+    cinstInstalldir (\v flags -> flags { cinstInstalldir = v })+    $ reqArg "DIR" (succeedReadE Flag) flagToList+  ]++parsecInstallMethod :: CabalParsing m => m InstallMethod+parsecInstallMethod = do+    name <- P.munch1 isAlpha+    case name of+        "copy"    -> pure InstallMethodCopy+        "symlink" -> pure InstallMethodSymlink+        _         -> P.unexpected $ "InstallMethod: " ++ name
+ src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs view
@@ -0,0 +1,68 @@+module Distribution.Client.CmdInstall.ClientInstallTargetSelector (+    WithoutProjectTargetSelector (..),+    parseWithoutProjectTargetSelector,+    woPackageNames,+    woPackageTargets,+    woPackageSpecifiers,+    ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Network.URI (URI, parseURI)++import Distribution.Client.TargetSelector+import Distribution.Client.Types+import Distribution.Compat.CharParsing             (char, optional)+import Distribution.Package+import Distribution.Simple.LocalBuildInfo          (ComponentName (CExeName))+import Distribution.Simple.Utils                   (die')+import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))+import Distribution.Version++data WithoutProjectTargetSelector+    = WoPackageId PackageId+    | WoPackageComponent PackageId ComponentName+    | WoURI URI+  deriving (Show)++parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector+parseWithoutProjectTargetSelector verbosity input =+    case explicitEitherParsec parser input of+        Right ts -> return ts+        Left err -> case parseURI input of+            Just uri -> return (WoURI uri)+            Nothing  -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err+  where+    parser :: CabalParsing m => m WithoutProjectTargetSelector+    parser = do+        pid <- parsec+        cn  <- optional (char ':' *> parsec)+        return $ case cn of+            Nothing -> WoPackageId pid+            Just cn' -> WoPackageComponent pid (CExeName cn')++woPackageNames  :: WithoutProjectTargetSelector -> [PackageName]+woPackageNames (WoPackageId pid)          = [pkgName pid]+woPackageNames (WoPackageComponent pid _) = [pkgName pid]+woPackageNames (WoURI _)                  = []++woPackageTargets  :: WithoutProjectTargetSelector -> TargetSelector+woPackageTargets (WoPackageId pid) =+    TargetPackageNamed (pkgName pid) Nothing+woPackageTargets (WoPackageComponent pid cn) =+    TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent+woPackageTargets (WoURI _) =+    TargetAllPackages (Just ExeKind)++woPackageSpecifiers  :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)+woPackageSpecifiers (WoPackageId pid)          = Right (pidPackageSpecifiers pid)+woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid)+woPackageSpecifiers (WoURI uri)                = Left uri++pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg+pidPackageSpecifiers pid+    | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []+    | otherwise                     = NamedPackage (pkgName pid)+        [ PackagePropertyVersion (thisVersion (pkgVersion pid))+        ]
+ src/Distribution/Client/CmdLegacy.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.Sandbox+    ( loadConfigOrSandboxConfig, findSavedDistPref )+import qualified Distribution.Client.Setup as Client+import Distribution.Client.SetupWrapper+    ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions )+import qualified Distribution.Simple.Setup as Setup+import Distribution.Simple.Command+import Distribution.Simple.Utils+    ( wrapText )+import Distribution.Verbosity+    ( normal )++import Control.Exception+    ( try )+import qualified Data.Text as T++-- Tweaked versions of code from Main.+regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action)+regularCmd ui action =+        CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand++wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ())+wrapperCmd ui verbosity' distPref =+  CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref) NormalCommand++wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ())+wrapperAction command verbosityFlag distPrefFlag =+  commandAddAction command+    { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do+    let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags)++    load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)+    let config = either (\(SomeException _) -> mempty) id load+    distPref <- findSavedDistPref config (distPrefFlag flags)+    let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }++    let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command }++    setupWrapper verbosity' setupScriptOptions Nothing+                 command' (const flags) (const extraArgs)++--++class HasVerbosity a where+    verbosity :: a -> Verbosity++instance HasVerbosity (Setup.Flag Verbosity) where+    verbosity = Setup.fromFlagOrDefault normal++instance (HasVerbosity a) => HasVerbosity (a, b) where+    verbosity (a, _) = verbosity a++instance (HasVerbosity a) => HasVerbosity (a, b, c) where+    verbosity (a , _, _) = verbosity a++instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where+    verbosity (a, _, _, _) = verbosity a++instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where+    verbosity (a, _, _, _, _) = verbosity a++instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where+    verbosity (a, _, _, _, _, _) = verbosity a++instance HasVerbosity Setup.BuildFlags where+    verbosity = verbosity . Setup.buildVerbosity++instance HasVerbosity Setup.ConfigFlags where+    verbosity = verbosity . Setup.configVerbosity++instance HasVerbosity Setup.ReplFlags where+    verbosity = verbosity . Setup.replVerbosity++instance HasVerbosity Client.FreezeFlags where+    verbosity = verbosity . Client.freezeVerbosity++instance HasVerbosity Setup.HaddockFlags where+    verbosity = verbosity . Setup.haddockVerbosity++instance HasVerbosity Client.UpdateFlags where+    verbosity = verbosity . Client.updateVerbosity++instance HasVerbosity Setup.CleanFlags where+    verbosity = verbosity . Setup.cleanVerbosity++--++legacyNote :: String -> String+legacyNote cmd = wrapText $+    "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++++    "It is a legacy feature and will be removed in a future release of cabal-install." +++    " Please file a bug if you cannot replicate a working v1- use case with the nix-style" +++    " commands.\n\n" ++++    "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"++toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)]+toLegacyCmd mkSpec = [toLegacy mkSpec]+  where+    toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type'+      where+        legUi = origUi+            { commandName = "v1-" ++ commandName+            , commandNotes = Just $ \pname -> case commandNotes of+                Just notes -> notes pname ++ "\n" ++ legacyNote commandName+                Nothing -> legacyNote commandName+            }++legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]+legacyCmd ui action = toLegacyCmd (regularCmd ui action)++legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())]+legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref)++newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]+newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi]+    where+        cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand++        newMsg = T.unpack . T.replace "v2-" "new-" . T.pack+        newUi = origUi+            { commandName = newMsg commandName+            , commandUsage = newMsg . commandUsage+            , commandDescription = (newMsg .) <$> commandDescription+            , commandNotes = (newMsg .) <$> commandNotes+            }++        defaultMsg = T.unpack . T.replace "v2-" "" . T.pack+        defaultUi = origUi+            { commandName = defaultMsg commandName+            , commandUsage = defaultMsg . commandUsage+            , commandDescription = (defaultMsg .) <$> commandDescription+            , commandNotes = (defaultMsg .) <$> commandNotes+            }
+ src/Distribution/Client/CmdListBin.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-}+module Distribution.Client.CmdListBin (+    listbinCommand,+    listbinAction,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.CmdErrorMessages+       (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets,+       renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs)+import Distribution.Client.DistDirLayout         (DistDirLayout (..), ProjectRoot (..))+import Distribution.Client.NixStyleOptions+       (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions)+import Distribution.Client.ProjectConfig+       (ProjectConfig, projectConfigConfigFile, projectConfigShared, withProjectOrGlobalConfig)+import Distribution.Client.ProjectFlags          (ProjectFlags (..))+import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.Setup                 (GlobalFlags (..))+import Distribution.Client.TargetProblem         (TargetProblem (..))+import Distribution.Simple.BuildPaths            (dllExtension, exeExtension)+import Distribution.Simple.Command               (CommandUI (..))+import Distribution.Simple.Setup                 (configVerbosity, fromFlagOrDefault)+import Distribution.Simple.Utils                 (die', ordNub, wrapText)+import Distribution.System                       (Platform)+import Distribution.Types.ComponentName          (showComponentName)+import Distribution.Types.UnitId                 (UnitId)+import Distribution.Types.UnqualComponentName    (UnqualComponentName)+import Distribution.Verbosity                    (silent, verboseStderr)+import System.Directory                          (getCurrentDirectory)+import System.FilePath                           ((<.>), (</>))++import qualified Data.Map                                as Map+import qualified Data.Set                                as Set+import qualified Distribution.Client.InstallPlan         as IP+import qualified Distribution.Simple.InstallDirs         as InstallDirs+import qualified Distribution.Solver.Types.ComponentDeps as CD++-------------------------------------------------------------------------------+-- Command+-------------------------------------------------------------------------------++listbinCommand :: CommandUI (NixStyleFlags ())+listbinCommand = CommandUI+    { commandName = "list-bin"+    , commandSynopsis = "list path to a single executable."+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n"+    , commandDescription  = Just $ \_ -> wrapText+        "List path to a build product."+    , commandNotes = Nothing+    , commandDefaultFlags = defaultNixStyleFlags ()+    , commandOptions      = nixStyleOptions (const [])+    }++-------------------------------------------------------------------------------+-- Action+-------------------------------------------------------------------------------++listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+listbinAction flags@NixStyleFlags{..} args globalFlags = do+    -- fail early if multiple target selectors specified+    target <- case args of+        []  -> die' verbosity "One target is required, none provided"+        [x] -> return x+        _   -> die' verbosity "One target is required, given multiple"++    -- configure+    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject+    let localPkgs = localPackages baseCtx++    -- elaborate target selectors+    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+        =<< readTargetSelectors localPkgs (Just ExeKind) [target]++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do+            -- Interpret the targets on the command line as build targets+            -- (as opposed to say repl or haddock targets).+            targets <- either (reportTargetProblems verbosity) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            -- Reject multiple targets, or at least targets in different+            -- components. It is ok to have two module/file targets in the+            -- same component, but not two that live in different components.+            --+            -- Note that we discard the target and return the whole 'TargetsMap',+            -- so this check will be repeated (and must succeed) after+            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.+            _ <- singleComponentOrElse+                   (reportTargetProblems+                      verbosity+                      [multipleTargetsProblem targets])+                   targets++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            return (elaboratedPlan', targets)++    (selectedUnitId, _selectedComponent) <-+      -- Slight duplication with 'runProjectPreBuildPhase'.+      singleComponentOrElse+        (die' verbosity $ "No or multiple targets given, but the run "+                       ++ "phase has been reached. This is a bug.")+        $ targetsMap buildCtx++    printPlan verbosity baseCtx buildCtx++    binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of+        Nothing  -> die' verbosity "No or multiple targets given..."+        Just gpp -> return $ IP.foldPlanPackage+            (const []) -- IPI don't have executables+            (elaboratedPackage distDirLayout (elaboratedShared buildCtx))+            gpp++    case binfiles of+        [exe] -> putStrLn exe+        _     -> die' verbosity "No or multiple targets given"+  where+    defaultVerbosity = verboseStderr silent+    verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)+    ignoreProject = flagIgnoreProject projectFlags+    prjConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here+    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)++    withProject :: IO (ProjectBaseContext, DistDirLayout)+    withProject = do+        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand+        return (baseCtx, distDirLayout baseCtx)++    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)+    withoutProject config = do+        cwd <- getCurrentDirectory+        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand+        return (baseCtx, distDirLayout baseCtx)++    -- this is copied from+    elaboratedPackage+        :: DistDirLayout+        -> ElaboratedSharedConfig+        -> ElaboratedConfiguredPackage+        -> [FilePath]+    elaboratedPackage distDirLayout elaboratedSharedConfig elab = case elabPkgOrComp elab of+        ElabPackage pkg ->+            [ bin+            | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg)+                                           (pkgExeDependencies pkg)+            , bin <- bin_file c+            ]+        ElabComponent comp -> bin_file (compSolverName comp)+      where+        dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab)++        bin_file c = case c of+            CD.ComponentExe s   -> [bin_file' s]+            CD.ComponentTest s  -> [bin_file' s]+            CD.ComponentBench s -> [bin_file' s]+            CD.ComponentFLib s  -> [flib_file' s]+            _                -> []++        plat :: Platform+        plat = pkgConfigPlatform elaboratedSharedConfig++        -- here and in PlanOutput,+        -- use binDirectoryFor?+        bin_file' s =+            if elabBuildStyle elab == BuildInplaceOnly+            then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat+            else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat++        flib_file' s =+            if elabBuildStyle elab == BuildInplaceOnly+            then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat+            else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat++-------------------------------------------------------------------------------+-- Target Problem: the very similar to CmdRun+-------------------------------------------------------------------------------++singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)+singleComponentOrElse action targetsMap =+  case Set.toList . distinctTargetComponents $ targetsMap+  of [(unitId, CExeName component)] -> return (unitId, component)+     [(unitId, CTestName component)] -> return (unitId, component)+     [(unitId, CBenchName component)] -> return (unitId, component)+     [(unitId, CFLibName component)] -> return (unitId, component)+     _   -> action++-- | This defines what a 'TargetSelector' means for the @list-bin@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @list-bin@ command we select the exe or flib if there is only one+-- and it's buildable. Fail if there are no or multiple buildable exe components.+--+selectPackageTargets :: TargetSelector+                     -> [AvailableTarget k] -> Either ListBinTargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there is exactly one buildable executable then we select that+  | [target] <- targetsExesBuildable+  = Right [target]++    -- but fail if there are multiple buildable executables.+  | not (null targetsExesBuildable)+  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')++    -- If there are executables but none are buildable then we report those+  | not (null targetsExes)+  = Left (TargetProblemNoneEnabled targetSelector targetsExes)++    -- If there are no executables but some other targets then we report that+  | not (null targets)+  = Left (noComponentsProblem targetSelector)++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    -- Targets that can be executed+    targetsExecutableLike =+      concatMap (\kind -> filterTargetsKind kind targets)+                [ExeKind, TestKind, BenchKind]+    (targetsExesBuildable,+     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike++    targetsExes             = forgetTargetsDetail targetsExecutableLike+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @run@ command we just need to check it is a executable-like+-- (an executable, a test, or a benchmark), in addition+-- to the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either ListBinTargetProblem  k+selectComponentTarget subtarget@WholeComponent t+  = case availableTargetComponentName t+    of CExeName _ -> component+       CTestName _ -> component+       CBenchName _ -> component+       CFLibName _ -> component+       _ -> Left (componentNotRightKindProblem pkgid cname)+    where pkgid = availableTargetPackageId t+          cname = availableTargetComponentName t+          component = selectComponentTargetBasic subtarget t++selectComponentTarget subtarget t+  = Left (isSubComponentProblem (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.+--+data ListBinProblem =+     -- | The 'TargetSelector' matches targets but no executables+     TargetProblemNoRightComps      TargetSelector++     -- | A single 'TargetSelector' matches multiple targets+   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]++     -- | Multiple 'TargetSelector's match multiple targets+   | TargetProblemMultipleTargets TargetsMap++     -- | The 'TargetSelector' refers to a component that is not an executable+   | TargetProblemComponentNotRightKind PackageId ComponentName++     -- | Asking to run an individual file or module is not supported+   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget+  deriving (Eq, Show)++type ListBinTargetProblem = TargetProblem ListBinProblem++noComponentsProblem :: TargetSelector -> ListBinTargetProblem+noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps++matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem+matchesMultipleProblem selector targets = CustomTargetProblem $+    TargetProblemMatchesMultiple selector targets++multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem+multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets++componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem+componentNotRightKindProblem pkgid name = CustomTargetProblem $+    TargetProblemComponentNotRightKind pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem ListBinProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+    TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderListBinTargetProblem++renderListBinTargetProblem :: ListBinTargetProblem -> String+renderListBinTargetProblem (TargetProblemNoTargets targetSelector) =+    case targetSelectorFilter targetSelector of+      Just kind | kind /= ExeKind+        -> "The list-bin command is for finding binaries, but the target '"+           ++ showTargetSelector targetSelector ++ "' refers to "+           ++ renderTargetSelector targetSelector ++ "."++      _ -> renderTargetProblemNoTargets "list-bin" targetSelector+renderListBinTargetProblem problem =+    renderTargetProblem "list-bin" renderListBinProblem problem++renderListBinProblem :: ListBinProblem -> String+renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =+    "The list-bin command is for finding a single binary at once. The target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " which includes "+ ++ renderListCommaAnd ( ("the "++) <$>+                         showComponentName <$>+                         availableTargetComponentName <$>+                         foldMap+                           (\kind -> filterTargetsKind kind targets)+                           [ExeKind, TestKind, BenchKind] )+ ++ "."++renderListBinProblem (TargetProblemMultipleTargets selectorMap) =+    "The list-bin command is for finding a single binary at once. The targets "+ ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"+                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]+ ++ " refer to different executables."++renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) =+    "The list-bin command is for finding binaries, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ prettyShow pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+    "The list-bin command can only find a binary as a whole, "+ ++ "not files or modules within them, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ "."+  where+    targetSelector = TargetComponent pkgid cname subtarget++renderListBinProblem (TargetProblemNoRightComps targetSelector) =+    "Cannot list-bin the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any executables or foreign libraries."
+ src/Distribution/Client/CmdRepl.hs view
@@ -0,0 +1,582 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- | cabal-install CLI command: repl+--+module Distribution.Client.CmdRepl (+    -- * The @repl@ CLI and action+    replCommand,+    replAction,++    -- * Internals exposed for testing+    matchesMultipleProblem,+    selectPackageTargets,+    selectComponentTarget+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Compat.Lens+import qualified Distribution.Types.Lens as L++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.CmdErrorMessages+         ( renderTargetSelector, showTargetSelector,+           renderTargetProblem,+           targetSelectorRefersToPkgs,+           renderComponentKind, renderListCommaAnd, renderListSemiAnd,+           componentKind, sortGroupOn, Plural(..) )+import Distribution.Client.TargetProblem+         ( TargetProblem(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.ProjectBuilding+         ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..), withProjectOrGlobalConfig+         , projectConfigConfigFile )+import Distribution.Client.ProjectFlags+         ( flagIgnoreProject )+import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectPlanning+       ( ElaboratedSharedConfig(..), ElaboratedInstallPlan )+import Distribution.Client.ProjectPlanning.Types+       ( elabOrderExeDependencies )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..) )+import qualified Distribution.Client.Setup as Client+import Distribution.Client.Types+         ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )+import Distribution.Simple.Setup+         ( fromFlagOrDefault, replOptions+         , Flag(..), toFlag, falseArg )+import Distribution.Simple.Command+         ( CommandUI(..), liftOptionL, usageAlternatives, option+         , ShowOrParseArgs, OptionField, reqArg )+import Distribution.Compiler+         ( CompilerFlavor(GHC) )+import Distribution.Simple.Compiler+         ( compilerCompatVersion )+import Distribution.Package+         ( Package(..), packageName, UnitId, installedUnitId )+import Distribution.PackageDescription.PrettyPrint+import Distribution.Parsec+         ( parsecCommaList )+import Distribution.ReadE+         ( ReadE, parsecToReadE )+import qualified Distribution.SPDX.License as SPDX+import Distribution.Solver.Types.SourcePackage+         ( SourcePackage(..) )+import Distribution.Types.BuildInfo+         ( BuildInfo(..), emptyBuildInfo )+import Distribution.Types.ComponentName+         ( componentNameString )+import Distribution.Types.CondTree+         ( CondTree(..), traverseCondTreeC )+import Distribution.Types.Dependency+         ( Dependency(..), mainLibSet )+import Distribution.Types.GenericPackageDescription+         ( emptyGenericPackageDescription )+import Distribution.Types.PackageDescription+         ( PackageDescription(..), emptyPackageDescription )+import Distribution.Types.PackageName.Magic+         ( fakePackageId )+import Distribution.Types.Library+         ( Library(..), emptyLibrary )+import Distribution.Types.Version+         ( mkVersion )+import Distribution.Types.VersionRange+         ( anyVersion )+import Distribution.Utils.Generic+         ( safeHead )+import Distribution.Verbosity+         ( normal, lessVerbose )+import Distribution.Simple.Utils+         ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist )+import Language.Haskell.Extension+         ( Language(..) )+import Distribution.CabalSpecVersion+         ( CabalSpecVersion (..) )++import Data.List+         ( (\\) )+import qualified Data.Map as Map+import qualified Data.Set as Set+import System.Directory+         ( getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive )+import System.FilePath+         ( (</>) )++type ReplFlags = [String]++data EnvFlags = EnvFlags+  { envPackages :: [Dependency]+  , envIncludeTransitive :: Flag Bool+  }++defaultEnvFlags :: EnvFlags+defaultEnvFlags = EnvFlags+  { envPackages = []+  , envIncludeTransitive = toFlag True+  }++envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]+envOptions _ =+  [ option ['b'] ["build-depends"]+    "Include additional packages in the environment presented to GHCi."+    envPackages (\p flags -> flags { envPackages = p ++ envPackages flags })+    (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String]))+  , option [] ["no-transitive-deps"]+    "Don't automatically include transitive dependencies of requested packages."+    envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })+    falseArg+  ]+  where+    dependenciesReadE :: ReadE [Dependency]+    dependenciesReadE =+      parsecToReadE+        ("couldn't parse dependencies: " ++)+        (parsecCommaList parsec)++replCommand :: CommandUI (NixStyleFlags (ReplFlags, EnvFlags))+replCommand = Client.installCommand {+  commandName         = "v2-repl",+  commandSynopsis     = "Open an interactive session for the given component.",+  commandUsage        = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ],+  commandDescription  = Just $ \_ -> wrapText $+        "Open an interactive session for a component within the project. The "+     ++ "available targets are the same as for the 'v2-build' command: "+     ++ "individual components within packages in the project, including "+     ++ "libraries, executables, test-suites or benchmarks. Packages can "+     ++ "also be specified in which case the library component in the "+     ++ "package will be used, or the (first listed) executable in the "+     ++ "package if there is no library.\n\n"++     ++ "Dependencies are built or rebuilt as necessary. Additional "+     ++ "configuration flags can be specified on the command line and these "+     ++ "extend the project configuration from the 'cabal.project', "+     ++ "'cabal.project.local' and other files.",+  commandNotes        = Just $ \pname ->+        "Examples, open an interactive session:\n"+     ++ "  " ++ pname ++ " v2-repl\n"+     ++ "    for the default component in the package in the current directory\n"+     ++ "  " ++ pname ++ " v2-repl pkgname\n"+     ++ "    for the default component in the package named 'pkgname'\n"+     ++ "  " ++ pname ++ " v2-repl ./pkgfoo\n"+     ++ "    for the default component in the package in the ./pkgfoo directory\n"+     ++ "  " ++ pname ++ " v2-repl cname\n"+     ++ "    for the component named 'cname'\n"+     ++ "  " ++ pname ++ " v2-repl pkgname:cname\n"+     ++ "    for the component 'cname' in the package 'pkgname'\n\n"+     ++ "  " ++ pname ++ " v2-repl --build-depends lens\n"+     ++ "    add the latest version of the library 'lens' to the default component "+        ++ "(or no componentif there is no project present)\n"+     ++ "  " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"+     ++ "    add a version (constrained between 4.15 and 4.18) of the library 'lens' "+        ++ "to the default component (or no component if there is no project present)\n",++  commandDefaultFlags = defaultNixStyleFlags ([], defaultEnvFlags),+  commandOptions = nixStyleOptions $ \showOrParseArgs ->+    map (liftOptionL _1) (replOptions showOrParseArgs) +++    map (liftOptionL _2) (envOptions showOrParseArgs)+  }++-- | The @repl@ command is very much like @build@. It brings the install plan+-- up to date, selects that part of the plan needed by the given or implicit+-- repl target and then executes the plan.+--+-- Compared to @build@ the difference is that only one target is allowed+-- (given or implicit) and the target type is repl rather than build. The+-- general plan execution infrastructure handles both build and repl targets.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO ()+replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do+    let+      with           = withProject    cliConfig             verbosity targetStrings+      without config = withoutProject (config <> cliConfig) verbosity targetStrings++    (baseCtx, targetSelectors, finalizer, replType) <-+      withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without++    when (buildSettingOnlyDeps (buildSettings baseCtx)) $+      die' verbosity $ "The repl command does not support '--only-dependencies'. "+          ++ "You may wish to use 'build --only-dependencies' and then "+          ++ "use 'repl'."++    (originalComponent, baseCtx') <- if null (envPackages envFlags)+      then return (Nothing, baseCtx)+      else+        -- Unfortunately, the best way to do this is to let the normal solver+        -- help us resolve the targets, but that isn't ideal for performance,+        -- especially in the no-project case.+        withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do+          -- targets should be non-empty map, but there's no NonEmptyMap yet.+          targets <- validatedTargets elaboratedPlan targetSelectors++          let+            (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets+            originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId+            oci = OriginalComponentInfo unitId originalDeps+            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId+            baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx++          return (Just oci, baseCtx')++    -- Now, we run the solver again with the added packages. While the graph+    -- won't actually reflect the addition of transitive dependencies,+    -- they're going to be available already and will be offered to the REPL+    -- and that's good enough.+    --+    -- In addition, to avoid a *third* trip through the solver, we are+    -- replicating the second half of 'runProjectPreBuildPhase' by hand+    -- here.+    (buildCtx, replFlags'') <- withInstallPlan verbosity baseCtx' $+      \elaboratedPlan elaboratedShared' -> do+        let ProjectBaseContext{..} = baseCtx'++        -- Recalculate with updated project.+        targets <- validatedTargets elaboratedPlan targetSelectors++        let+          elaboratedPlan' = pruneInstallPlanToTargets+                              TargetActionRepl+                              targets+                              elaboratedPlan+          includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags)++        pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared'+                                          elaboratedPlan'++        let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages+                                pkgsBuildStatus elaboratedPlan'+        debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')++        let+          buildCtx = ProjectBuildContext+            { elaboratedPlanOriginal = elaboratedPlan+            , elaboratedPlanToExecute = elaboratedPlan''+            , elaboratedShared = elaboratedShared'+            , pkgsBuildStatus+            , targetsMap = targets+            }++          ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared'++          -- First version of GHC where GHCi supported the flag we need.+          -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html+          minGhciScriptVersion = mkVersion [7, 6]++          replFlags' = case originalComponent of+            Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci+            Nothing  -> []+          replFlags'' = case replType of+            GlobalRepl scriptPath+              | Just version <- compilerCompatVersion GHC compiler+              , version >= minGhciScriptVersion -> ("-ghci-script" ++ scriptPath) : replFlags'+            _                                   -> replFlags'++        return (buildCtx, replFlags'')++    let buildCtx' = buildCtx+          { elaboratedShared = (elaboratedShared buildCtx)+                { pkgConfigReplOptions = replFlags ++ replFlags'' }+          }+    printPlan verbosity baseCtx' buildCtx'++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx'+    runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes+    finalizer+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    ignoreProject = flagIgnoreProject projectFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here+    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)++    validatedTargets elaboratedPlan targetSelectors = do+      -- Interpret the targets on the command line as repl targets+      -- (as opposed to say build or haddock targets).+      targets <- either (reportTargetProblems verbosity) return+          $ resolveTargets+              selectPackageTargets+              selectComponentTarget+              elaboratedPlan+              Nothing+              targetSelectors++      -- Reject multiple targets, or at least targets in different+      -- components. It is ok to have two module/file targets in the+      -- same component, but not two that live in different components.+      when (Set.size (distinctTargetComponents targets) > 1) $+        reportTargetProblems verbosity+          [multipleTargetsProblem targets]++      return targets++data OriginalComponentInfo = OriginalComponentInfo+  { ociUnitId :: UnitId+  , ociOriginalDeps :: [UnitId]+  }+  deriving (Show)++-- | Tracks what type of GHCi instance we're creating.+data ReplType = ProjectRepl+              | GlobalRepl FilePath -- ^ The 'FilePath' argument is path to a GHCi+                                    --   script responsible for changing to the+                                    --   correct directory. Only works on GHC geq+                                    --   7.6, though. 🙁+              deriving (Show, Eq)++withProject :: ProjectConfig -> Verbosity -> [String]+            -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)+withProject cliConfig verbosity targetStrings = do+  baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand++  targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                 =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings++  return (baseCtx, targetSelectors, return (), ProjectRepl)++withoutProject :: ProjectConfig -> Verbosity -> [String]+               -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)+withoutProject config verbosity extraArgs = do+  unless (null extraArgs) $+    die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs++  globalTmp <- getTemporaryDirectory+  tempDir <- createTempDirectory globalTmp "cabal-repl."++  -- We need to create a dummy package that lives in our dummy project.+  let+    sourcePackage = SourcePackage+      { srcpkgPackageId     = pkgId+      , srcpkgDescription   = genericPackageDescription+      , srcpkgSource        = LocalUnpackedPackage tempDir+      , srcpkgDescrOverride = Nothing+      }+    genericPackageDescription = emptyGenericPackageDescription+      & L.packageDescription .~ packageDescription+      & L.condLibrary        .~ Just (CondNode library [baseDep] [])+    packageDescription = emptyPackageDescription+      { package = pkgId+      , specVersion = CabalSpecV2_2+      , licenseRaw = Left SPDX.NONE+      }+    library = emptyLibrary { libBuildInfo = buildInfo }+    buildInfo = emptyBuildInfo+      { targetBuildDepends = [baseDep]+      , defaultLanguage = Just Haskell2010+      }+    baseDep = Dependency "base" anyVersion mainLibSet+    pkgId = fakePackageId++  writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription++  let ghciScriptPath = tempDir </> "setcwd.ghci"+  cwd <- getCurrentDirectory+  writeFile ghciScriptPath (":cd " ++ cwd)++  distDirLayout <- establishDummyDistDirLayout verbosity config tempDir+  baseCtx <-+    establishDummyProjectBaseContext+      verbosity+      config+      distDirLayout+      [SpecificSourcePackage sourcePackage]+      OtherCommand++  let+    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]+    finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir)++  return (baseCtx, targetSelectors, finalizer, GlobalRepl ghciScriptPath)++addDepsToProjectTarget :: [Dependency]+                       -> PackageId+                       -> ProjectBaseContext+                       -> ProjectBaseContext+addDepsToProjectTarget deps pkgId ctx =+    (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx+  where+    addDeps :: PackageSpecifier UnresolvedSourcePackage+            -> PackageSpecifier UnresolvedSourcePackage+    addDeps (SpecificSourcePackage pkg)+      | packageId pkg /= pkgId = SpecificSourcePackage pkg+      | SourcePackage{..} <- pkg =+        SpecificSourcePackage $ pkg { srcpkgDescription =+          srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f)+                            %~ (deps ++)+        }+    addDeps spec = spec++generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags+generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags+  where+    exeDeps :: [UnitId]+    exeDeps =+      foldMap+        (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)+        (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])++    deps, deps', trans, trans' :: [UnitId]+    flags :: ReplFlags+    deps   = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId+    deps'  = deps \\ ociOriginalDeps+    trans  = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'+    trans' = trans \\ ociOriginalDeps+    flags  = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps)+      $ if includeTransitive then trans' else deps'++-- | This defines what a 'TargetSelector' means for the @repl@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For repl we select:+--+-- * the library if there is only one and it's buildable; or+--+-- * the exe if there is only one and it's buildable; or+--+-- * any other buildable component.+--+-- Fail if there are no buildable lib\/exe components, or if there are+-- multiple libs or exes.+--+selectPackageTargets  :: TargetSelector+                      -> [AvailableTarget k] -> Either ReplTargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there is exactly one buildable library then we select that+  | [target] <- targetsLibsBuildable+  = Right [target]++    -- but fail if there are multiple buildable libraries.+  | not (null targetsLibsBuildable)+  = Left (matchesMultipleProblem targetSelector targetsLibsBuildable')++    -- If there is exactly one buildable executable then we select that+  | [target] <- targetsExesBuildable+  = Right [target]++    -- but fail if there are multiple buildable executables.+  | not (null targetsExesBuildable)+  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')++    -- If there is exactly one other target then we select that+  | [target] <- targetsBuildable+  = Right [target]++    -- but fail if there are multiple such targets+  | not (null targetsBuildable)+  = Left (matchesMultipleProblem targetSelector targetsBuildable')++    -- If there are targets but none are buildable then we report those+  | not (null targets)+  = Left (TargetProblemNoneEnabled targetSelector targets')++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targets'                = forgetTargetsDetail targets+    (targetsLibsBuildable,+     targetsLibsBuildable') = selectBuildableTargets'+                            . filterTargetsKind LibKind+                            $ targets+    (targetsExesBuildable,+     targetsExesBuildable') = selectBuildableTargets'+                            . filterTargetsKind ExeKind+                            $ targets+    (targetsBuildable,+     targetsBuildable')     = selectBuildableTargetsWith'+                                (isRequested targetSelector) targets++    -- When there's a target filter like "pkg:tests" then we do select tests,+    -- but if it's just a target like "pkg" then we don't build tests unless+    -- they are requested by default (i.e. by using --enable-tests)+    isRequested (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False+    isRequested (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False+    isRequested _ _ = True+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @repl@ command we just need the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either ReplTargetProblem k+selectComponentTarget = selectComponentTargetBasic+++data ReplProblem+  = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]++    -- | Multiple 'TargetSelector's match multiple targets+  | TargetProblemMultipleTargets TargetsMap+  deriving (Eq, Show)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.+--+type ReplTargetProblem = TargetProblem ReplProblem++matchesMultipleProblem+  :: TargetSelector+  -> [AvailableTarget ()]+  -> ReplTargetProblem+matchesMultipleProblem targetSelector targetsExesBuildable =+  CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable++multipleTargetsProblem+  :: TargetsMap+  -> ReplTargetProblem+multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets++reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderReplTargetProblem++renderReplTargetProblem :: TargetProblem ReplProblem -> String+renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem++renderReplProblem :: ReplProblem -> String+renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) =+    "Cannot open a repl for multiple components at once. The target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " which "+ ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ")+ ++ renderListSemiAnd+      [ "the " ++ renderComponentKind Plural ckind ++ " " +++        renderListCommaAnd+          [ maybe (prettyShow pkgname) prettyShow (componentNameString cname)+          | t <- ts+          , let cname   = availableTargetComponentName t+                pkgname = packageName (availableTargetPackageId t)+          ]+      | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets+      ]+ ++ ".\n\n" ++ explanationSingleComponentLimitation+  where+    availableTargetComponentKind = componentKind+                                 . availableTargetComponentName++renderReplProblem (TargetProblemMultipleTargets selectorMap) =+    "Cannot open a repl for multiple components at once. The targets "+ ++ renderListCommaAnd+      [ "'" ++ showTargetSelector ts ++ "'"+      | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]+ ++ " refer to different components."+ ++ ".\n\n" ++ explanationSingleComponentLimitation++explanationSingleComponentLimitation :: String+explanationSingleComponentLimitation =+    "The reason for this limitation is that current versions of ghci do not "+ ++ "support loading multiple components as source. Load just one component "+ ++ "and when you make changes to a dependent component then quit and reload."
+ src/Distribution/Client/CmdRun.hs view
@@ -0,0 +1,638 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | cabal-install CLI command: run+--+module Distribution.Client.CmdRun (+    -- * The @run@ CLI and action+    runCommand,+    runAction,+    handleShebang, validScript,++    -- * Internals exposed for testing+    matchesMultipleProblem,+    noExesProblem,+    selectPackageTargets,+    selectComponentTarget+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (toList)++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages+         ( renderTargetSelector, showTargetSelector,+           renderTargetProblem,+           renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,+           targetSelectorFilter, renderListCommaAnd )+import Distribution.Client.TargetProblem+         ( TargetProblem (..) )++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+         ( GlobalFlags(..), ConfigFlags(..) )+import Distribution.Client.GlobalFlags+         ( defaultGlobalFlags )+import Distribution.Simple.Flag+         ( fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Types.ComponentName+         ( showComponentName )+import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest)+import Distribution.Verbosity+         ( normal )+import Distribution.Simple.Utils+         ( wrapText, warn, die', ordNub, info, notice+         , createTempDirectory, handleDoesNotExist )+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..), ProjectConfigShared(..)+         , withProjectOrGlobalConfig )+import Distribution.Client.ProjectFlags+         ( flagIgnoreProject )+import Distribution.Client.ProjectPlanning+         ( ElaboratedConfiguredPackage(..)+         , ElaboratedInstallPlan, binDirectoryFor )+import Distribution.Client.ProjectPlanning.Types+         ( dataDirsEnvironmentForPlan )+import Distribution.Client.TargetSelector+         ( TargetSelectorProblem(..), TargetString(..) )+import Distribution.Client.InstallPlan+         ( toList, foldPlanPackage )+import Distribution.Types.UnqualComponentName+         ( UnqualComponentName, unUnqualComponentName )+import Distribution.Simple.Program.Run+         ( runProgramInvocation, ProgramInvocation(..),+           emptyProgramInvocation )+import Distribution.Types.UnitId+         ( UnitId )++import Distribution.Client.Types+         ( PackageLocation(..), PackageSpecifier(..) )+import Distribution.FieldGrammar+         ( takeFields, parseFieldGrammar )+import Distribution.PackageDescription.FieldGrammar+         ( executableFieldGrammar )+import Distribution.PackageDescription.PrettyPrint+         ( writeGenericPackageDescription )+import Distribution.Parsec+         ( Position(..) )+import Distribution.Fields+         ( ParseResult, parseString, parseFatalFailure, readFields )+import qualified Distribution.SPDX.License as SPDX+import Distribution.Solver.Types.SourcePackage as SP+         ( SourcePackage(..) )+import Distribution.Types.BuildInfo+         ( BuildInfo(..) )+import Distribution.Types.CondTree+         ( CondTree(..) )+import Distribution.Types.Executable+         ( Executable(..) )+import Distribution.Types.GenericPackageDescription as GPD+         ( GenericPackageDescription(..), emptyGenericPackageDescription )+import Distribution.Types.PackageDescription+         ( PackageDescription(..), emptyPackageDescription )+import Distribution.Types.PackageName.Magic+         ( fakePackageId )+import Language.Haskell.Extension+         ( Language(..) )++import qualified Data.ByteString.Char8 as BS+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Text.Parsec as P+import System.Directory+         ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist )+import System.FilePath+         ( (</>), isValid, isPathSeparator, takeExtension )+++runCommand :: CommandUI (NixStyleFlags ())+runCommand = CommandUI+  { commandName         = "v2-run"+  , commandSynopsis     = "Run an executable."+  , commandUsage        = usageAlternatives "v2-run"+                          [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ]+  , commandDescription  = Just $ \pname -> wrapText $+         "Runs the specified executable-like component (an executable, a test, "+      ++ "or a benchmark), first ensuring it is up to date.\n\n"++      ++ "Any executable-like component in any package in the project can be "+      ++ "specified. A package can be specified if contains just one "+      ++ "executable-like. The default is to use the package in the current "+      ++ "directory if it contains just one executable-like.\n\n"++      ++ "Extra arguments can be passed to the program, but use '--' to "+      ++ "separate arguments for the program from arguments for " ++ pname+      ++ ". The executable is run in an environment where it can find its "+      ++ "data files inplace in the build tree.\n\n"++      ++ "Dependencies are built or rebuilt as necessary. Additional "+      ++ "configuration flags can be specified on the command line and these "+      ++ "extend the project configuration from the 'cabal.project', "+      ++ "'cabal.project.local' and other files."+  , commandNotes        = Just $ \pname ->+         "Examples:\n"+      ++ "  " ++ pname ++ " v2-run\n"+      ++ "    Run the executable-like in the package in the current directory\n"+      ++ "  " ++ pname ++ " v2-run foo-tool\n"+      ++ "    Run the named executable-like (in any package in the project)\n"+      ++ "  " ++ pname ++ " v2-run pkgfoo:foo-tool\n"+      ++ "    Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"+      ++ "  " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"+      ++ "    Build with '-O2' and run the program, passing it extra arguments.\n"++  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = nixStyleOptions (const [])+  }++-- | The @run@ command runs a specified executable-like component, building it+-- first if necessary. The component can be either an executable, a test,+-- or a benchmark. This is particularly useful for passing arguments to+-- exes/tests/benchs by simply appending them after a @--@.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+runAction flags@NixStyleFlags {..} targetStrings globalFlags = do+    globalTmp <- getTemporaryDirectory+    tmpDir <- createTempDirectory globalTmp "cabal-repl."++    let+      with =+        establishProjectBaseContext verbosity cliConfig OtherCommand+      without config = do+        distDirLayout <- establishDummyDistDirLayout verbosity (config <> cliConfig) tmpDir+        establishDummyProjectBaseContext verbosity (config <> cliConfig) distDirLayout [] OtherCommand++    baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with without++    let+      scriptOrError script err = do+        exists <- doesFileExist script+        let pol | takeExtension script == ".lhs" = LiterateHaskell+                | otherwise                      = PlainHaskell+        if exists+          then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tmpDir+          else reportTargetSelectorProblems verbosity err++    (baseCtx', targetSelectors) <-+      readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings)+        >>= \case+          Left err@(TargetSelectorNoTargetsInProject:_)+            | (script:_) <- targetStrings -> scriptOrError script err+          Left err@(TargetSelectorNoSuch t _:_)+            | TargetString1 script <- t   -> scriptOrError script err+          Left err@(TargetSelectorExpected t _ _:_)+            | TargetString1 script <- t   -> scriptOrError script err+          Left err   -> reportTargetSelectorProblems verbosity err+          Right sels -> return (baseCtx, sels)++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do++            when (buildSettingOnlyDeps (buildSettings baseCtx')) $+              die' verbosity $+                  "The run command does not support '--only-dependencies'. "+               ++ "You may wish to use 'build --only-dependencies' and then "+               ++ "use 'run'."++            -- Interpret the targets on the command line as build targets+            -- (as opposed to say repl or haddock targets).+            targets <- either (reportTargetProblems verbosity) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            -- Reject multiple targets, or at least targets in different+            -- components. It is ok to have two module/file targets in the+            -- same component, but not two that live in different components.+            --+            -- Note that we discard the target and return the whole 'TargetsMap',+            -- so this check will be repeated (and must succeed) after+            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.+            _ <- singleExeOrElse+                   (reportTargetProblems+                      verbosity+                      [multipleTargetsProblem targets])+                   targets++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionBuild+                                    targets+                                    elaboratedPlan+            return (elaboratedPlan', targets)++    (selectedUnitId, selectedComponent) <-+      -- Slight duplication with 'runProjectPreBuildPhase'.+      singleExeOrElse+        (die' verbosity $ "No or multiple targets given, but the run "+                       ++ "phase has been reached. This is a bug.")+        $ targetsMap buildCtx++    printPlan verbosity baseCtx' buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx+    runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes+++    let elaboratedPlan = elaboratedPlanToExecute buildCtx+        matchingElaboratedConfiguredPackages =+          matchingPackagesByUnitId+            selectedUnitId+            elaboratedPlan++    let exeName = unUnqualComponentName selectedComponent++    -- In the common case, we expect @matchingElaboratedConfiguredPackages@+    -- to consist of a single element that provides a single way of building+    -- an appropriately-named executable. In that case we take that+    -- package and continue.+    --+    -- However, multiple packages/components could provide that+    -- executable, or it's possible we don't find the executable anywhere+    -- in the build plan. I suppose in principle it's also possible that+    -- a single package provides an executable in two different ways,+    -- though that's probably a bug if. Anyway it's a good lint to report+    -- an error in all of these cases, even if some seem like they+    -- shouldn't happen.+    pkg <- case matchingElaboratedConfiguredPackages of+      [] -> die' verbosity $ "Unknown executable "+                          ++ exeName+                          ++ " in package "+                          ++ prettyShow selectedUnitId+      [elabPkg] -> do+        info verbosity $ "Selecting "+                       ++ prettyShow selectedUnitId+                       ++ " to supply " ++ exeName+        return elabPkg+      elabPkgs -> die' verbosity+        $ "Multiple matching executables found matching "+        ++ exeName+        ++ ":\n"+        ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)+    let exePath = binDirectoryFor (distDirLayout baseCtx)+                                  (elaboratedShared buildCtx)+                                  pkg+                                  exeName+               </> exeName+    let args = drop 1 targetStrings+        dryRun = buildSettingDryRun (buildSettings baseCtx)+              || buildSettingOnlyDownload (buildSettings baseCtx)++    if dryRun+       then notice verbosity "Running of executable suppressed by flag(s)"+       else+         runProgramInvocation+           verbosity+           emptyProgramInvocation {+             progInvokePath  = exePath,+             progInvokeArgs  = args,+             progInvokeEnv   = dataDirsEnvironmentForPlan+                                 (distDirLayout baseCtx)+                                 elaboratedPlan+           }++    handleDoesNotExist () (removeDirectoryRecursive tmpDir)+  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    ignoreProject = flagIgnoreProject projectFlags+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here+    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)++-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was+-- invoked as a script interpreter, i.e. via+--+-- > #! /usr/bin/env cabal+--+-- or+--+-- > #! /usr/bin/cabal+--+-- As the first argument passed to `cabal` will be a filepath to the+-- script to be interpreted.+--+-- See also 'handleShebang'+validScript :: String -> IO Bool+validScript script+  | isValid script && any isPathSeparator script = doesFileExist script+  | otherwise = return False++-- | Handle @cabal@ invoked as script interpreter, see also 'validScript'+--+-- First argument is the 'FilePath' to the script to be executed; second+-- argument is a list of arguments to be passed to the script.+handleShebang :: FilePath -> [String] -> IO ()+handleShebang script args =+  runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags++parseScriptBlock :: BS.ByteString -> ParseResult Executable+parseScriptBlock str =+    case readFields str of+        Right fs -> do+            let (fields, _) = takeFields fs+            parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")+        Left perr -> parseFatalFailure pos (show perr) where+            ppos = P.errorPos perr+            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)++readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable+readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"++readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString)+readScriptBlockFromScript verbosity pol str = do+    str' <- case extractScriptBlock pol str of+              Left e -> die' verbosity $ "Failed extracting script block: " ++ e+              Right x -> return x+    when (BS.all isSpace str') $ warn verbosity "Empty script block"+    (\x -> (x, noShebang)) <$> readScriptBlock verbosity str'+  where+    noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str++-- | Extract the first encountered script metadata block started end+-- terminated by the tokens+--+-- * @{- cabal:@+--+-- * @-}@+--+-- appearing alone on lines (while tolerating trailing whitespace).+-- These tokens are not part of the 'Right' result.+--+-- In case of missing or unterminated blocks a 'Left'-error is+-- returned.+extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString+extractScriptBlock _pol str = goPre (BS.lines str)+  where+    isStartMarker = (== startMarker) . stripTrailSpace+    isEndMarker   = (== endMarker) . stripTrailSpace++    stripTrailSpace = fst . BS.spanEnd isSpace++    -- before start marker+    goPre ls = case dropWhile (not . isStartMarker) ls of+                 [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"+                 (_:ls') -> goBody [] ls'++    goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"+    goBody acc (l:ls)+      | isEndMarker l = Right $! BS.unlines $ reverse acc+      | otherwise     = goBody (l:acc) ls++    startMarker, endMarker :: BS.ByteString+    startMarker = fromString "{- cabal:"+    endMarker   = fromString "-}"++data PlainOrLiterate+    = PlainHaskell+    | LiterateHaskell++handleScriptCase+  :: Verbosity+  -> PlainOrLiterate+  -> ProjectBaseContext+  -> FilePath+  -> BS.ByteString+  -> IO (ProjectBaseContext, [TargetSelector])+handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do+  (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents++  -- We need to create a dummy package that lives in our dummy project.+  let+    mainName = case pol of+      PlainHaskell    -> "Main.hs"+      LiterateHaskell -> "Main.lhs"++    sourcePackage = SourcePackage+      { srcpkgPackageId      = pkgId+      , srcpkgDescription    = genericPackageDescription+      , srcpkgSource         = LocalUnpackedPackage tmpDir+      , srcpkgDescrOverride  = Nothing+      }+    genericPackageDescription  = emptyGenericPackageDescription+      { GPD.packageDescription = packageDescription+      , condExecutables        = [("script", CondNode executable' targetBuildDepends [])]+      }+    executable' = executable+      { modulePath = mainName+      , buildInfo = binfo+        { defaultLanguage =+          case defaultLanguage of+            just@(Just _) -> just+            Nothing       -> Just Haskell2010+        }+      }+    binfo@BuildInfo{..} = buildInfo executable+    packageDescription = emptyPackageDescription+      { package = pkgId+      , specVersion = CabalSpecV2_2+      , licenseRaw = Left SPDX.NONE+      }+    pkgId = fakePackageId++  writeGenericPackageDescription (tmpDir </> "fake-package.cabal") genericPackageDescription+  BS.writeFile (tmpDir </> mainName) contents'++  let+    baseCtx' = baseCtx+      { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] }+    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]++  return (baseCtx', targetSelectors)++singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)+singleExeOrElse action targetsMap =+  case Set.toList . distinctTargetComponents $ targetsMap+  of [(unitId, CExeName component)] -> return (unitId, component)+     [(unitId, CTestName component)] -> return (unitId, component)+     [(unitId, CBenchName component)] -> return (unitId, component)+     _   -> action++-- | Filter the 'ElaboratedInstallPlan' keeping only the+-- 'ElaboratedConfiguredPackage's that match the specified+-- 'UnitId'.+matchingPackagesByUnitId :: UnitId+                         -> ElaboratedInstallPlan+                         -> [ElaboratedConfiguredPackage]+matchingPackagesByUnitId uid =+          catMaybes+          . fmap (foldPlanPackage+                    (const Nothing)+                    (\x -> if elabUnitId x == uid+                           then Just x+                           else Nothing))+          . toList++-- | This defines what a 'TargetSelector' means for the @run@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @run@ command we select the exe if there is only one and it's+-- buildable. Fail if there are no or multiple buildable exe components.+--+selectPackageTargets :: TargetSelector+                     -> [AvailableTarget k] -> Either RunTargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there is exactly one buildable executable then we select that+  | [target] <- targetsExesBuildable+  = Right [target]++    -- but fail if there are multiple buildable executables.+  | not (null targetsExesBuildable)+  = Left (matchesMultipleProblem targetSelector targetsExesBuildable')++    -- If there are executables but none are buildable then we report those+  | not (null targetsExes)+  = Left (TargetProblemNoneEnabled targetSelector targetsExes)++    -- If there are no executables but some other targets then we report that+  | not (null targets)+  = Left (noExesProblem targetSelector)++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    -- Targets that can be executed+    targetsExecutableLike =+      concatMap (\kind -> filterTargetsKind kind targets)+                [ExeKind, TestKind, BenchKind]+    (targetsExesBuildable,+     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike++    targetsExes             = forgetTargetsDetail targetsExecutableLike+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @run@ command we just need to check it is a executable-like+-- (an executable, a test, or a benchmark), in addition+-- to the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either RunTargetProblem  k+selectComponentTarget subtarget@WholeComponent t+  = case availableTargetComponentName t+    of CExeName _ -> component+       CTestName _ -> component+       CBenchName _ -> component+       _ -> Left (componentNotExeProblem pkgid cname)+    where pkgid = availableTargetPackageId t+          cname = availableTargetComponentName t+          component = selectComponentTargetBasic subtarget t++selectComponentTarget subtarget t+  = Left (isSubComponentProblem (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.+--+data RunProblem =+     -- | The 'TargetSelector' matches targets but no executables+     TargetProblemNoExes      TargetSelector++     -- | A single 'TargetSelector' matches multiple targets+   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]++     -- | Multiple 'TargetSelector's match multiple targets+   | TargetProblemMultipleTargets TargetsMap++     -- | The 'TargetSelector' refers to a component that is not an executable+   | TargetProblemComponentNotExe PackageId ComponentName++     -- | Asking to run an individual file or module is not supported+   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget+  deriving (Eq, Show)++type RunTargetProblem = TargetProblem RunProblem++noExesProblem :: TargetSelector -> RunTargetProblem+noExesProblem = CustomTargetProblem . TargetProblemNoExes++matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem+matchesMultipleProblem selector targets = CustomTargetProblem $+    TargetProblemMatchesMultiple selector targets++multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem+multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets++componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem+componentNotExeProblem pkgid name = CustomTargetProblem $+    TargetProblemComponentNotExe pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem RunProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+    TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a+reportTargetProblems verbosity =+    die' verbosity . unlines . map renderRunTargetProblem++renderRunTargetProblem :: RunTargetProblem -> String+renderRunTargetProblem (TargetProblemNoTargets targetSelector) =+    case targetSelectorFilter targetSelector of+      Just kind | kind /= ExeKind+        -> "The run command is for running executables, but the target '"+           ++ showTargetSelector targetSelector ++ "' refers to "+           ++ renderTargetSelector targetSelector ++ "."++      _ -> renderTargetProblemNoTargets "run" targetSelector+renderRunTargetProblem problem =+    renderTargetProblem "run" renderRunProblem problem++renderRunProblem :: RunProblem -> String+renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) =+    "The run command is for running a single executable at once. The target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " which includes "+ ++ renderListCommaAnd ( ("the "++) <$>+                         showComponentName <$>+                         availableTargetComponentName <$>+                         foldMap+                           (\kind -> filterTargetsKind kind targets)+                           [ExeKind, TestKind, BenchKind] )+ ++ "."++renderRunProblem (TargetProblemMultipleTargets selectorMap) =+    "The run command is for running a single executable at once. The targets "+ ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"+                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]+ ++ " refer to different executables."++renderRunProblem (TargetProblemComponentNotExe pkgid cname) =+    "The run command is for running executables, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ prettyShow pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+    "The run command can only run an executable as a whole, "+ ++ "not files or modules within them, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ "."+  where+    targetSelector = TargetComponent pkgid cname subtarget++renderRunProblem (TargetProblemNoExes targetSelector) =+    "Cannot run the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any executables."
+ src/Distribution/Client/CmdSdist.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}+module Distribution.Client.CmdSdist+    ( sdistCommand, sdistAction, packageToSdist+    , OutputFormat(..)) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.CmdErrorMessages+    ( Plural(..), renderComponentKind )+import Distribution.Client.ProjectOrchestration+    ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), defaultNixStyleFlags )+import Distribution.Client.TargetSelector+    ( TargetSelector(..), ComponentKind+    , readTargetSelectors, reportTargetSelectorProblems )+import Distribution.Client.Setup+    ( GlobalFlags(..) )+import Distribution.Solver.Types.SourcePackage+    ( SourcePackage(..) )+import Distribution.Client.Types+    ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )+import Distribution.Client.DistDirLayout+    ( DistDirLayout(..), ProjectRoot (..) )+import Distribution.Client.ProjectConfig+    ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )+import Distribution.Client.ProjectFlags+     ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions )++import Distribution.Compat.Lens+    ( _1, _2 )+import Distribution.Package+    ( Package(packageId) )+import Distribution.PackageDescription.Configuration+    ( flattenPackageDescription )+import Distribution.ReadE+    ( succeedReadE )+import Distribution.Simple.Command+    ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs )+import Distribution.Simple.PreProcess+    ( knownSuffixHandlers )+import Distribution.Simple.Setup+    ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe+    , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref+    )+import Distribution.Simple.SrcDist+    ( listPackageSourcesWithDie )+import Distribution.Client.SrcDist+    ( packageDirToSdist )+import Distribution.Simple.Utils+    ( die', notice, withOutputMarker, wrapText )+import Distribution.Types.ComponentName+    ( ComponentName, showComponentName )+import Distribution.Types.PackageName+    ( PackageName, unPackageName )+import Distribution.Verbosity+    ( normal )+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)++import qualified Data.ByteString.Lazy.Char8 as BSL+import System.Directory+    ( getCurrentDirectory+    , createDirectoryIfMissing, makeAbsolute+    )+import System.FilePath+    ( (</>), (<.>), makeRelative, normalise )++-------------------------------------------------------------------------------+-- Command+-------------------------------------------------------------------------------++sdistCommand :: CommandUI (ProjectFlags, SdistFlags)+sdistCommand = CommandUI+    { commandName = "v2-sdist"+    , commandSynopsis = "Generate a source distribution file (.tar.gz)."+    , commandUsage = \pname ->+        "Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n"+    , commandDescription  = Just $ \_ -> wrapText+        "Generates tarballs of project packages suitable for upload to Hackage."+    , commandNotes = Nothing+    , commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)+    , commandOptions = \showOrParseArgs ->+        map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) +++        map (liftOptionL _2) (sdistOptions showOrParseArgs)+    }++-------------------------------------------------------------------------------+-- Flags+-------------------------------------------------------------------------------++data SdistFlags = SdistFlags+    { sdistVerbosity     :: Flag Verbosity+    , sdistDistDir       :: Flag FilePath+    , sdistListSources   :: Flag Bool+    , sdistNulSeparated  :: Flag Bool+    , sdistOutputPath    :: Flag FilePath+    }++defaultSdistFlags :: SdistFlags+defaultSdistFlags = SdistFlags+    { sdistVerbosity     = toFlag normal+    , sdistDistDir       = mempty+    , sdistListSources   = toFlag False+    , sdistNulSeparated  = toFlag False+    , sdistOutputPath    = mempty+    }++sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]+sdistOptions showOrParseArgs =+    [ optionVerbosity+        sdistVerbosity (\v flags -> flags { sdistVerbosity = v })+    , optionDistPref+        sdistDistDir (\dd flags -> flags { sdistDistDir = dd })+        showOrParseArgs+    , option ['l'] ["list-only"]+        "Just list the sources, do not make a tarball"+        sdistListSources (\v flags -> flags { sdistListSources = v })+        trueArg+    , option [] ["null-sep"]+        "Separate the source files with NUL bytes rather than newlines."+        sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })+        trueArg+    , option ['o'] ["output-directory", "outputdir"]+        "Choose the output directory of this command. '-' sends all output to stdout"+        sdistOutputPath (\o flags -> flags { sdistOutputPath = o })+        (reqArg "PATH" (succeedReadE Flag) flagToList)+    ]++-------------------------------------------------------------------------------+-- Action+-------------------------------------------------------------------------------++sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()+sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do+    (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject++    let localPkgs = localPackages baseCtx++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+        =<< readTargetSelectors localPkgs Nothing targetStrings++    -- elaborate path, create target directory+    mOutputPath' <- case mOutputPath of+        Just "-"  -> return (Just "-")+        Just path -> do+            abspath <- makeAbsolute path+            createDirectoryIfMissing True abspath+            return (Just abspath)+        Nothing   -> do+            createDirectoryIfMissing True (distSdistDirectory distDirLayout)+            return Nothing++    let format :: OutputFormat+        format =+            if | listSources, nulSeparated -> SourceList '\0'+               | listSources               -> SourceList '\n'+               | otherwise                 -> TarGzArchive++        ext = case format of+                SourceList _  -> "list"+                TarGzArchive  -> "tar.gz"++        outputPath pkg = case mOutputPath' of+            Just path+                | path == "-" -> "-"+                | otherwise   -> path </> prettyShow (packageId pkg) <.> ext+            Nothing+                | listSources -> "-"+                | otherwise   -> distSdistFile distDirLayout (packageId pkg)+++    case reifyTargetSelectors localPkgs targetSelectors of+        Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs+        Right pkgs+            | length pkgs > 1, not listSources, Just "-" <- mOutputPath' ->+                die' verbosity "Can't write multiple tarballs to standard output!"+            | otherwise ->+                traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs+  where+    verbosity      = fromFlagOrDefault normal sdistVerbosity+    listSources    = fromFlagOrDefault False sdistListSources+    nulSeparated   = fromFlagOrDefault False sdistNulSeparated+    mOutputPath    = flagToMaybe sdistOutputPath+    ignoreProject  = flagIgnoreProject++    prjConfig :: ProjectConfig+    prjConfig = commandLineFlagsToProjectConfig+        globalFlags+        (defaultNixStyleFlags ())+          { configFlags = (configFlags $ defaultNixStyleFlags ())+            { configVerbosity = sdistVerbosity+            , configDistPref = sdistDistDir+            }+          }+        mempty++    globalConfigFlag = projectConfigConfigFile (projectConfigShared prjConfig)++    withProject :: IO (ProjectBaseContext, DistDirLayout)+    withProject = do+        baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand+        return (baseCtx, distDirLayout baseCtx)++    withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)+    withoutProject config = do+        cwd <- getCurrentDirectory+        baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand+        return (baseCtx, distDirLayout baseCtx)++data OutputFormat = SourceList Char+                  | TarGzArchive+                  deriving (Show, Eq)++packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()+packageToSdist verbosity projectRootDir format outputFile pkg = do+    let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))+    dir0 <- case srcpkgSource pkg of+             LocalUnpackedPackage path             -> pure (Right path)+             RemoteSourceRepoPackage _ (Just tgz)  -> pure (Left tgz)+             RemoteSourceRepoPackage {}            -> death+             LocalTarballPackage tgz               -> pure (Left tgz)+             RemoteTarballPackage _ (Just tgz)     -> pure (Left tgz)+             RemoteTarballPackage {}               -> death+             RepoTarballPackage {}                 -> death++    let -- Write String to stdout or file, using the default TextEncoding.+        write str+          | outputFile == "-" = putStr (withOutputMarker verbosity str)+          | otherwise = do+            writeFile outputFile str+            notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"+        -- Write raw ByteString to stdout or file as it is, without encoding.+        writeLBS lbs+          | outputFile == "-" = BSL.putStr lbs+          | otherwise = do+            BSL.writeFile outputFile lbs+            notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"++    case dir0 of+      Left tgz -> do+        case format of+          TarGzArchive -> do+            writeLBS =<< BSL.readFile tgz+          _ -> die' verbosity ("cannot convert tarball package to " ++ show format)++      Right dir -> case format of+        SourceList nulSep -> do+          let gpd :: GenericPackageDescription+              gpd = srcpkgDescription pkg++          let thisDie :: Verbosity -> String -> IO a+              thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s++          files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers+          let files = nub $ sort $ map normalise files'+          let prefix = makeRelative projectRootDir dir+          write $ concat [prefix </> i ++ [nulSep] | i <- files]++        TarGzArchive -> do+          packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS++--++reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]+reifyTargetSelectors pkgs sels =+    case partitionEithers (foldMap go sels) of+        ([], sels') -> Right sels'+        (errs, _)   -> Left errs+    where+        flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg+        flatten _ = error "The impossible happened: how do we not know about a local package?"+        pkgs' = fmap flatten pkgs++        getPkg pid = case find ((== pid) . packageId) pkgs' of+            Just pkg -> Right pkg+            Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages."++        go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]+        go (TargetPackage _ pids Nothing) = fmap getPkg pids+        go (TargetAllPackages Nothing) = Right <$> pkgs'++        go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)]+        go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)]++        go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)]+        go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)]++        go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)]++data TargetProblem = AllComponentsOnly ComponentKind+                   | NonlocalPackageNotAllowed PackageName+                   | ComponentsNotAllowed ComponentName++renderTargetProblem :: TargetProblem -> String+renderTargetProblem (AllComponentsOnly kind) =+    "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package "+    ++ "for distribution. Only entire packages may be packaged for distribution."+renderTargetProblem (ComponentsNotAllowed cname) =+    "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. "+    ++ "Only entire packages may be packaged for distribution."+renderTargetProblem (NonlocalPackageNotAllowed pname) =+    "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not "+    ++ "local to this project."
+ src/Distribution/Client/CmdTest.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE RecordWildCards #-}++-- | cabal-install CLI command: test+--+module Distribution.Client.CmdTest (+    -- * The @test@ CLI and action+    testCommand,+    testAction,++    -- * Internals exposed for testing+    isSubComponentProblem,+    notTestProblem,+    noTestsProblem,+    selectPackageTargets,+    selectComponentTarget+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ProjectOrchestration+import Distribution.Client.CmdErrorMessages+         ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural,+           renderTargetProblem,+           renderTargetProblemNoTargets, targetSelectorPluralPkgs )+import Distribution.Client.TargetProblem+         ( TargetProblem (..) )+import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Setup+         ( GlobalFlags(..), ConfigFlags(..) )+import Distribution.Simple.Setup+         ( TestFlags(..), fromFlagOrDefault )+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )+import Distribution.Simple.Flag+         ( Flag(..) )+import Distribution.Verbosity+         ( normal )+import Distribution.Simple.Utils+         ( notice, wrapText, die' )++import qualified System.Exit (exitSuccess)+++testCommand :: CommandUI (NixStyleFlags ())+testCommand = CommandUI+  { commandName         = "v2-test"+  , commandSynopsis     = "Run test-suites"+  , commandUsage        = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ]+  , commandDescription  = Just $ \_ -> wrapText $+        "Runs the specified test-suites, first ensuring they are up to "+     ++ "date.\n\n"++     ++ "Any test-suite in any package in the project can be specified. "+     ++ "A package can be specified in which case all the test-suites in the "+     ++ "package are run. The default is to run all the test-suites in the "+     ++ "package in the current directory.\n\n"++     ++ "Dependencies are built or rebuilt as necessary. Additional "+     ++ "configuration flags can be specified on the command line and these "+     ++ "extend the project configuration from the 'cabal.project', "+     ++ "'cabal.project.local' and other files.\n\n"++     ++ "To pass command-line arguments to a test suite, see the "+     ++ "v2-run command."+  , commandNotes        = Just $ \pname ->+        "Examples:\n"+     ++ "  " ++ pname ++ " v2-test\n"+     ++ "    Run all the test-suites in the package in the current directory\n"+     ++ "  " ++ pname ++ " v2-test pkgname\n"+     ++ "    Run all the test-suites in the package named pkgname\n"+     ++ "  " ++ pname ++ " v2-test cname\n"+     ++ "    Run the test-suite named cname\n"+     ++ "  " ++ pname ++ " v2-test cname --enable-coverage\n"+     ++ "    Run the test-suite built with code coverage (including local libs used)\n"++  , commandDefaultFlags = defaultNixStyleFlags ()+  , commandOptions      = nixStyleOptions (const [])+  }++++-- | The @test@ command is very much like @build@. It brings the install plan+-- up to date, selects that part of the plan needed by the given or implicit+-- test target(s) and then executes the plan.+--+-- Compared to @build@ the difference is that there's also test targets+-- which are ephemeral.+--+-- For more details on how this works, see the module+-- "Distribution.Client.ProjectOrchestration"+--+testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+testAction flags@NixStyleFlags {..} targetStrings globalFlags = do++    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand++    targetSelectors <- either (reportTargetSelectorProblems verbosity) return+                   =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings++    buildCtx <-+      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do++            when (buildSettingOnlyDeps (buildSettings baseCtx)) $+              die' verbosity $+                  "The test command does not support '--only-dependencies'. "+               ++ "You may wish to use 'build --only-dependencies' and then "+               ++ "use 'test'."++            -- Interpret the targets on the command line as test targets+            -- (as opposed to say build or haddock targets).+            targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return+                     $ resolveTargets+                         selectPackageTargets+                         selectComponentTarget+                         elaboratedPlan+                         Nothing+                         targetSelectors++            let elaboratedPlan' = pruneInstallPlanToTargets+                                    TargetActionTest+                                    targets+                                    elaboratedPlan+            return (elaboratedPlan', targets)++    printPlan verbosity baseCtx buildCtx++    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx+    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes+  where+    failWhenNoTestSuites = testFailWhenNoTestSuites testFlags+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags++-- | This defines what a 'TargetSelector' means for the @test@ command.+-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,+-- or otherwise classifies the problem.+--+-- For the @test@ command we select all buildable test-suites,+-- or fail if there are no test-suites or no buildable test-suites.+--+selectPackageTargets  :: TargetSelector+                      -> [AvailableTarget k] -> Either TestTargetProblem [k]+selectPackageTargets targetSelector targets++    -- If there are any buildable test-suite targets then we select those+  | not (null targetsTestsBuildable)+  = Right targetsTestsBuildable++    -- If there are test-suites but none are buildable then we report those+  | not (null targetsTests)+  = Left (TargetProblemNoneEnabled targetSelector targetsTests)++    -- If there are no test-suite but some other targets then we report that+  | not (null targets)+  = Left (noTestsProblem targetSelector)++    -- If there are no targets at all then we report that+  | otherwise+  = Left (TargetProblemNoTargets targetSelector)+  where+    targetsTestsBuildable = selectBuildableTargets+                          . filterTargetsKind TestKind+                          $ targets++    targetsTests          = forgetTargetsDetail+                          . filterTargetsKind TestKind+                          $ targets+++-- | For a 'TargetComponent' 'TargetSelector', check if the component can be+-- selected.+--+-- For the @test@ command we just need to check it is a test-suite, in addition+-- to the basic checks on being buildable etc.+--+selectComponentTarget :: SubComponentTarget+                      -> AvailableTarget k -> Either TestTargetProblem k+selectComponentTarget subtarget@WholeComponent t+  | CTestName _ <- availableTargetComponentName t+  = either Left return $+           selectComponentTargetBasic subtarget t+  | otherwise+  = Left (notTestProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t))++selectComponentTarget subtarget t+  = Left (isSubComponentProblem+           (availableTargetPackageId t)+           (availableTargetComponentName t)+           subtarget)++-- | The various error conditions that can occur when matching a+-- 'TargetSelector' against 'AvailableTarget's for the @test@ command.+--+data TestProblem =+     -- | The 'TargetSelector' matches targets but no test-suites+     TargetProblemNoTests     TargetSelector++     -- | The 'TargetSelector' refers to a component that is not a test-suite+   | TargetProblemComponentNotTest PackageId ComponentName++     -- | Asking to test an individual file or module is not supported+   | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget+  deriving (Eq, Show)+++type TestTargetProblem = TargetProblem TestProblem+++noTestsProblem :: TargetSelector -> TargetProblem TestProblem+noTestsProblem = CustomTargetProblem . TargetProblemNoTests++notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem+notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name++isSubComponentProblem+  :: PackageId+  -> ComponentName+  -> SubComponentTarget+  -> TargetProblem TestProblem+isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $+  TargetProblemIsSubComponent pkgid name subcomponent++reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a+reportTargetProblems verbosity failWhenNoTestSuites problems =+  case (failWhenNoTestSuites, problems) of+    (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) ->+      die' verbosity problemsMessage+    (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do+      notice verbosity (renderAllowedNoTestsProblem selector)+      System.Exit.exitSuccess+    (_, _) -> die' verbosity problemsMessage+    where+      problemsMessage = unlines . map renderTestTargetProblem $ problems++-- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't+--   @die@ when the target problem is 'TargetProblemNoTests'.+--   Instead, we display a notice saying that no tests have run and+--   indicate how this behaviour was enabled.+renderAllowedNoTestsProblem :: TargetSelector -> String+renderAllowedNoTestsProblem selector =+    "No tests to run for " ++ renderTargetSelector selector++renderTestTargetProblem :: TestTargetProblem -> String+renderTestTargetProblem (TargetProblemNoTargets targetSelector) =+    case targetSelectorFilter targetSelector of+      Just kind | kind /= TestKind+        -> "The test command is for running test suites, but the target '"+           ++ showTargetSelector targetSelector ++ "' refers to "+           ++ renderTargetSelector targetSelector ++ "."+           ++ "\n" ++ show targetSelector++      _ -> renderTargetProblemNoTargets "test" targetSelector+renderTestTargetProblem problem =+    renderTargetProblem "test" renderTestProblem problem+++renderTestProblem :: TestProblem -> String+renderTestProblem (TargetProblemNoTests targetSelector) =+    "Cannot run tests for the target '" ++ showTargetSelector targetSelector+ ++ "' which refers to " ++ renderTargetSelector targetSelector+ ++ " because "+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"+ ++ " not contain any test suites."++renderTestProblem (TargetProblemComponentNotTest pkgid cname) =+    "The test command is for running test suites, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ " from the package "+ ++ prettyShow pkgid ++ "."+  where+    targetSelector = TargetComponent pkgid cname WholeComponent++renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) =+    "The test command can only run test suites as a whole, "+ ++ "not files or modules within them, but the target '"+ ++ showTargetSelector targetSelector ++ "' refers to "+ ++ renderTargetSelector targetSelector ++ "."+  where+    targetSelector = TargetComponent pkgid cname subtarget
+ src/Distribution/Client/CmdUpdate.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ViewPatterns    #-}++-- | cabal-install CLI command: update+--+module Distribution.Client.CmdUpdate (+    updateCommand,+    updateAction,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.NixStyleOptions+         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )+import Distribution.Client.Compat.Directory+         ( setModificationTime )+import Distribution.Client.ProjectOrchestration+import Distribution.Client.ProjectConfig+         ( ProjectConfig(..)+         , ProjectConfigShared(projectConfigConfigFile)+         , projectConfigWithSolverRepoContext+         , withProjectOrGlobalConfig )+import Distribution.Client.ProjectFlags+         ( ProjectFlags (..) )+import Distribution.Client.Types+         ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName )+import Distribution.Client.HttpUtils+         ( DownloadResult(..) )+import Distribution.Client.FetchUtils+         ( downloadIndex )+import Distribution.Client.JobControl+         ( newParallelJobControl, spawnJob, collectJob )+import Distribution.Client.Setup+         ( GlobalFlags, ConfigFlags(..)+         , UpdateFlags, defaultUpdateFlags+         , RepoContext(..) )+import Distribution.Simple.Flag+         ( fromFlagOrDefault )+import Distribution.Simple.Utils+         ( die', notice, wrapText, writeFileAtomic, noticeNoWrap )+import Distribution.Verbosity+         ( normal, lessVerbose )+import Distribution.Client.IndexUtils.Timestamp+import Distribution.Client.IndexUtils.IndexState+import Distribution.Client.IndexUtils+         ( updateRepoIndexCache, Index(..), writeIndexTimestamp+         , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile )++import qualified Data.Maybe as Unsafe (fromJust)+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++import qualified Data.ByteString.Lazy       as BS+import Distribution.Client.GZipUtils (maybeDecompress)+import System.FilePath ((<.>), dropExtension)+import Data.Time (getCurrentTime)+import Distribution.Simple.Command+         ( CommandUI(..), usageAlternatives )++import qualified Hackage.Security.Client as Sec++updateCommand :: CommandUI (NixStyleFlags ())+updateCommand = CommandUI+  { commandName         = "v2-update"+  , commandSynopsis     = "Updates list of known packages."+  , commandUsage        = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ]+  , commandDescription  = Just $ \_ -> wrapText $+          "For all known remote repositories, download the package list."++  , commandNotes        = Just $ \pname ->+        "REPO has the format <repo-id>[,<index-state>] where index-state follows\n"+     ++ "the same format and syntax that is supported by the --index-state flag.\n\n"+     ++ "Examples:\n"+     ++ "  " ++ pname ++ " v2-update\n"+     ++ "    Download the package list for all known remote repositories.\n\n"+     ++ "  " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n"+     ++ "  " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"+     ++ "  " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n"+     ++ "  " ++ pname ++ " v2-update hackage.haskell.org\n"+     ++ "    Download hackage.haskell.org at a specific index state.\n\n"+     ++ "  " ++ pname ++ " new update hackage.haskell.org head.hackage\n"+     ++ "    Download hackage.haskell.org and head.hackage\n"+     ++ "    head.hackage must be a known repo-id. E.g. from\n"+     ++ "    your cabal.project(.local) file.\n"++  , commandOptions      = nixStyleOptions $ const []+  , commandDefaultFlags = defaultNixStyleFlags ()+  }++data UpdateRequest = UpdateRequest+  { _updateRequestRepoName  :: RepoName+  , _updateRequestRepoState :: RepoIndexState+  } deriving (Show)++instance Pretty UpdateRequest where+    pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s++instance Parsec UpdateRequest where+  parsec = do+      name <- parsec+      state <- P.char ',' *> parsec <|> pure IndexStateHead+      return (UpdateRequest name state)++updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()+updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do+  let ignoreProject = flagIgnoreProject projectFlags++  projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag+    (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)+    (\globalConfig -> return $ globalConfig <> cliConfig)++  projectConfigWithSolverRepoContext verbosity+    (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)+    $ \repoCtxt -> do++    let repos :: [Repo]+        repos = repoContextRepos repoCtxt++        parseArg :: String -> IO UpdateRequest+        parseArg s = case simpleParsec s of+          Just r -> return r+          Nothing -> die' verbosity $+                     "'v2-update' unable to parse repo: \"" ++ s ++ "\""++    updateRepoRequests <- traverse parseArg extraArgs++    unless (null updateRepoRequests) $ do+      let remoteRepoNames = map repoName repos+          unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests+                            , not (r `elem` remoteRepoNames)]+      unless (null unknownRepos) $+        die' verbosity $ "'v2-update' repo(s): \""+                         ++ intercalate "\", \"" (map unRepoName unknownRepos)+                         ++ "\" can not be found in known remote repo(s): "+                         ++ intercalate ", " (map unRepoName remoteRepoNames)++    let reposToUpdate :: [(Repo, RepoIndexState)]+        reposToUpdate = case updateRepoRequests of+          -- If we are not given any specific repository, update all+          -- repositories to HEAD.+          [] -> map (,IndexStateHead) repos+          updateRequests -> let repoMap = [(repoName r, r) | r <- repos]+                                lookup' k = Unsafe.fromJust (lookup k repoMap)+                            in [ (lookup' name, state)+                               | (UpdateRequest name state) <- updateRequests ]++    case reposToUpdate of+      [] ->+        notice verbosity "No remote repositories configured"+      [(remoteRepo, _)] ->+        notice verbosity $ "Downloading the latest package list from "+                        ++ unRepoName (repoName remoteRepo)+      _ -> notice verbosity . unlines+              $ "Downloading the latest package lists from: "+              : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate++    unless (null reposToUpdate) $ do+      jobCtrl <- newParallelJobControl (length reposToUpdate)+      traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)+        reposToUpdate+      traverse_ (\_ -> collectJob jobCtrl) reposToUpdate++  where+    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here+    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)++updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)+           -> IO ()+updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do+  transport <- repoContextGetTransport repoCtxt+  case repo of+    RepoLocalNoIndex{} -> do+      let index = RepoIndex repoCtxt repo+      updatePackageIndexCacheFile verbosity index++    RepoRemote{..} -> do+      downloadResult <- downloadIndex transport verbosity+                        repoRemote repoLocalDir+      case downloadResult of+        FileAlreadyInCache ->+          setModificationTime (indexBaseName repo <.> "tar")+          =<< getCurrentTime+        FileDownloaded indexPath -> do+          writeFileAtomic (dropExtension indexPath) . maybeDecompress+                                                  =<< BS.readFile indexPath+          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do+      let index = RepoIndex repoCtxt repo+      -- NB: This may be a nullTimestamp if we've never updated before+      current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo+      -- NB: always update the timestamp, even if we didn't actually+      -- download anything+      writeIndexTimestamp index indexState+      ce <- if repoContextIgnoreExpiry repoCtxt+              then Just `fmap` getCurrentTime+              else return Nothing+      updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce++      let rname = remoteRepoName (repoRemote repo)++      -- Update cabal's internal index as well so that it's not out of sync+      -- (If all access to the cache goes through hackage-security this can go)+      case updated of+        Sec.NoUpdates  -> do+          now <- getCurrentTime+          setModificationTime (indexBaseName repo <.> "tar") now+          noticeNoWrap verbosity $+            "Package list of " ++ prettyShow rname +++            " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts)++        Sec.HasUpdates -> do+          updateRepoIndexCache verbosity index+          new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo+          noticeNoWrap verbosity $+            "Updated package list of " ++ prettyShow rname +++            " to the index-state " ++ prettyShow (IndexStateTime new_ts)++          -- TODO: This will print multiple times if there are multiple+          -- repositories: main problem is we don't have a way of updating+          -- a specific repo.  Once we implement that, update this.+          when (current_ts /= nullTimestamp) $+            noticeNoWrap verbosity $+              "To revert to previous state run:\n" +++              "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"
+ src/Distribution/Client/Compat/Directory.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+module Distribution.Client.Compat.Directory (+    setModificationTime,+    createFileLink,+    pathIsSymbolicLink,+    getSymbolicLinkTarget,+    ) where++#if MIN_VERSION_directory(1,2,3)+import System.Directory (setModificationTime)+#else+import Data.Time.Clock (UTCTime)+#endif++#if MIN_VERSION_directory(1,3,1)+import System.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)+#elif defined(MIN_VERSION_unix)+import System.Posix.Files (createSymbolicLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink)+#endif++-------------------------------------------------------------------------------+-- setModificationTime+-------------------------------------------------------------------------------++#if !MIN_VERSION_directory(1,2,3)++setModificationTime :: FilePath -> UTCTime -> IO ()+setModificationTime _fp _t = return ()++#endif++-------------------------------------------------------------------------------+-- Symlink+-------------------------------------------------------------------------------++#if MIN_VERSION_directory(1,3,1)+#elif defined(MIN_VERSION_unix)+createFileLink :: FilePath -> FilePath -> IO ()+createFileLink = createSymbolicLink++pathIsSymbolicLink :: FilePath -> IO Bool+pathIsSymbolicLink fp = do+    status <- getSymbolicLinkStatus fp+    return (isSymbolicLink status)++getSymbolicLinkTarget :: FilePath -> IO FilePath+getSymbolicLinkTarget = readSymbolicLink++#else+createFileLink :: FilePath -> FilePath -> IO ()+createFileLink _ _ = fail "Symlinking feature not available"++pathIsSymbolicLink :: FilePath -> IO Bool+pathIsSymbolicLink _ = fail "Symlinking feature not available"++getSymbolicLinkTarget :: FilePath -> IO FilePath+getSymbolicLinkTarget _ = fail "Symlinking feature not available"+#endif
+ src/Distribution/Client/Compat/ExecutablePath.hs view
@@ -0,0 +1,166 @@+{-# 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++import Prelude++-- 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++-- 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
+ src/Distribution/Client/Compat/FilePerms.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Distribution.Client.Compat.FilePerms (+  setFileOrdinary,+  setFileExecutable,+  setFileHidden,+  ) where++import Prelude (FilePath, IO, return, ($))++#ifndef mingw32_HOST_OS+import System.Posix.Types+         ( FileMode )+import System.Posix.Internals+         ( c_chmod )+import Foreign.C+         ( withCString+         , throwErrnoPathIfMinus1_ )+#else+import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN)+#endif /* mingw32_HOST_OS */++setFileHidden, setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x+setFileHidden     _    = return ()++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode name m =+  withCString name $ \s ->+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+setFileHidden  path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN+#endif
+ src/Distribution/Client/Compat/Orphans.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Client.Compat.Orphans () where++import Control.Exception             (SomeException)+import Distribution.Compat.Binary    (Binary (..))+import Distribution.Compat.Typeable  (typeRep)+import Distribution.Utils.Structured (Structure (Nominal), Structured (..))+import Network.URI                   (URI (..), URIAuth (..))+import Prelude                       (error, return)++-------------------------------------------------------------------------------+-- network-uri+-------------------------------------------------------------------------------++-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier+-- versions do not, so we use manual Binary instances here+instance Binary URI where+  put (URI a b c d e) = do put a; put b; put c; put d; put e+  get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get+           return (URI a b c d e)++instance Structured URI where+    structure p = Nominal (typeRep p) 0 "URI" []++instance Binary URIAuth where+    put (URIAuth a b c) = do put a; put b; put c+    get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++--FIXME: Duncan Coutts: this is a total cheat+--Added in 46aa019ec85e313e257d122a3549cce01996c566+instance Binary SomeException where+    put _ = return ()+    get = error "cannot serialise exceptions"++instance Structured SomeException where+    structure p = Nominal (typeRep p) 0 "SomeException" []
+ src/Distribution/Client/Compat/Prelude.hs view
@@ -0,0 +1,24 @@+-- to suppress WARNING in "Distribution.Compat.Prelude.Internal"+{-# OPTIONS_GHC -fno-warn-deprecations #-}++-- | This module does two things:+--+-- * Acts as a compatibility layer, like @base-compat@.+--+-- * Provides commonly used imports.+--+-- This module is a superset of "Distribution.Compat.Prelude" (which+-- this module re-exports)+--+module Distribution.Client.Compat.Prelude+  ( module Distribution.Compat.Prelude.Internal+  , module X+  ) where++import Distribution.Client.Compat.Orphans ()+import Distribution.Compat.Prelude.Internal+import Prelude ()++import Distribution.Parsec    as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec)+import Distribution.Pretty    as X (Pretty (..), prettyShow)+import Distribution.Verbosity as X (Verbosity)
+ src/Distribution/Client/Compat/Process.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- |+-- 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++import Prelude (FilePath, IO, String, return, (||))++import           Control.Exception (catch, throw)+import           System.Exit       (ExitCode (ExitFailure))+import           System.IO.Error   (isDoesNotExistError, isPermissionError)+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\" and+--   \"permission denied\" exceptions and turns them into+--   @ExitFailure@s.+--+-- TODO: this doesn't use 'Distrubution.Compat.Process'.+--+readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String)+readProcessWithExitCode cmd args input =+  P.readProcessWithExitCode cmd args input+    `catch` \e -> if isDoesNotExistError e || isPermissionError e+                    then return (ExitFailure 127, "", "")+                    else throw e
+ src/Distribution/Client/Compat/Semaphore.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+module Distribution.Client.Compat.Semaphore+    ( QSem+    , newQSem+    , waitQSem+    , signalQSem+    ) where++import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip)++import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,+                               writeTVar)+import Control.Exception (mask_, onException)+import Control.Monad (join, unless)+import Data.Typeable (Typeable)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++-- | 'QSem' is a quantity semaphore in which the resource is aqcuired+-- and released in units of one. It provides guaranteed FIFO ordering+-- for satisfying blocked `waitQSem` calls.+--+data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])+  deriving (Eq, Typeable)++newQSem :: Int -> IO QSem+newQSem i = atomically $ do+  q <- newTVar i+  b1 <- newTVar []+  b2 <- newTVar []+  return (QSem q b1 b2)++waitQSem :: QSem -> IO ()+waitQSem s@(QSem q _b1 b2) =+  mask_ $ join $ atomically $ do+        -- join, because if we need to block, we have to add a TVar to+        -- the block queue.+        -- mask_, because we need a chance to set up an exception handler+        -- after the join returns.+     v <- readTVar q+     if v == 0+        then do b <- newTVar False+                ys <- readTVar b2+                writeTVar b2 (b:ys)+                return (wait b)+        else do writeTVar q $! v - 1+                return (return ())+  where+    --+    -- very careful here: if we receive an exception, then we need to+    --  (a) write True into the TVar, so that another signalQSem doesn't+    --      try to wake up this thread, and+    --  (b) if the TVar is *already* True, then we need to do another+    --      signalQSem to avoid losing a unit of the resource.+    --+    -- The 'wake' function does both (a) and (b), so we can just call+    -- it here.+    --+    wait t =+      flip onException (wake s t) $+      atomically $ do+        b <- readTVar t+        unless b retry+++wake :: QSem -> TVar Bool -> IO ()+wake s x = join $ atomically $ do+      b <- readTVar x+      if b then return (signalQSem s)+           else do writeTVar x True+                   return (return ())++{-+ property we want:++   bracket waitQSem (\_ -> signalQSem) (\_ -> ...)++ never loses a unit of the resource.+-}++signalQSem :: QSem -> IO ()+signalQSem s@(QSem q b1 b2) =+  mask_ $ join $ atomically $ do+      -- join, so we don't force the reverse inside the txn+      -- mask_ is needed so we don't lose a wakeup+    v <- readTVar q+    if v /= 0+       then do writeTVar q $! v + 1+               return (return ())+       else do xs <- readTVar b1+               checkwake1 xs+  where+    checkwake1 [] = do+      ys <- readTVar b2+      checkwake2 ys+    checkwake1 (x:xs) = do+      writeTVar b1 xs+      return (wake s x)++    checkwake2 [] = do+      writeTVar q 1+      return (return ())+    checkwake2 (y:ys) = do+      let (z:|zs) = NE.reverse (y:|ys)+      writeTVar b1 zs+      writeTVar b2 []+      return (wake s z)
+ src/Distribution/Client/Config.hs view
@@ -0,0 +1,1479 @@+{-# LANGUAGE DeriveGeneric #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Config+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for handling saved state such as known packages, known servers and+-- downloaded packages.+-----------------------------------------------------------------------------+module Distribution.Client.Config (+    SavedConfig(..),+    loadConfig,+    getConfigFilePath,++    showConfig,+    showConfigWithComments,+    parseConfig,++    getCabalDir,+    defaultConfigFile,+    defaultCacheDir,+    defaultCompiler,+    defaultInstallPath,+    defaultLogsDir,+    defaultUserInstall,++    baseSavedConfig,+    commentSavedConfig,+    initialSavedConfig,+    configFieldDescriptions,+    haddockFlagsFields,+    installDirsFields,+    withProgramsFields,+    withProgramOptionsFields,+    userConfigDiff,+    userConfigUpdate,+    createDefaultConfigFile,++    remoteRepoFields,+    postProcessRepo,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Language.Haskell.Extension ( Language(Haskell2010) )++import Distribution.Deprecated.ViewAsFieldDescr+         ( viewAsFieldDescr )++import Distribution.Client.Types+         ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo+         , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps+         , RepoName (..), unRepoName+         )+import Distribution.Client.Types.Credentials (Username (..), Password (..))+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import qualified Distribution.Client.Init.Types as IT+         ( InitFlags(..) )+import qualified Distribution.Client.Init.Defaults as IT+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand, defaultGlobalFlags+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags+         , initOptions+         , InstallFlags(..), installOptions, defaultInstallFlags+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand )+import Distribution.Client.CmdInstall.ClientInstallFlags+         ( ClientInstallFlags(..), defaultClientInstallFlags+         , clientInstallOptions )+import Distribution.Utils.NubList+         ( NubList, fromNubList, toNubList, overNubList )++import Distribution.Simple.Compiler+         ( DebugInfoLevel(..), OptimisationLevel(..) )+import Distribution.Simple.Setup+         ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , HaddockFlags(..), haddockOptions, defaultHaddockFlags+         , TestFlags(..), defaultTestFlags+         , BenchmarkFlags(..), defaultBenchmarkFlags+         , installDirsOptions, optionDistPref+         , programDbPaths', programDbOptions+         , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Simple.InstallDirs+         ( InstallDirs(..), defaultInstallDirs+         , PathTemplate, toPathTemplate )+import Distribution.Deprecated.ParseUtils+         ( FieldDescr(..), liftField, runP+         , ParseResult(..), PError(..), PWarning(..)+         , locatedErrorMsg, showPWarning+         , readFields, warning, lineNo+         , simpleField, listField, spaceListField+         , parseOptCommaList, parseTokenQ, syntaxError+         , simpleFieldParsec, listFieldParsec+         )+import Distribution.Client.ParseUtils+         ( parseFields, ppFields, ppSection )+import Distribution.Client.HttpUtils+         ( isOldHackageURI )+import qualified Distribution.Deprecated.ParseUtils as ParseUtils+         ( Field(..) )+import Distribution.Simple.Command+         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) )+import Distribution.Simple.Program+         ( defaultProgramDb )+import Distribution.Simple.Utils+         ( die', notice, warn, lowercase, cabalVersion, toUTF8BS )+import Distribution.Client.Utils+         ( cabalInstallVersion )+import Distribution.Compiler+         ( CompilerFlavor(..), defaultCompilerFlavor )+import Distribution.Verbosity+         ( normal )+import qualified Distribution.Compat.CharParsing as P+import Distribution.Client.ProjectFlags (ProjectFlags (..))+import Distribution.Solver.Types.ConstraintSource++import qualified Text.PrettyPrint as Disp+         ( render, text, empty )+import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath)+import Text.PrettyPrint+         ( ($+$) )+import Text.PrettyPrint.HughesPJ+         ( text, Doc )+import System.Directory+         ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile )+import Network.URI+         ( URI(..), URIAuth(..), parseURI )+import System.FilePath+         ( (<.>), (</>), takeDirectory )+import System.IO.Error+         ( isDoesNotExistError )+import Distribution.Compat.Environment+         ( getEnvironment, lookupEnv )+import qualified Data.Map as M+import qualified Data.ByteString as BS++--+-- * Configuration saved in the config file+--++data SavedConfig = SavedConfig+    { savedGlobalFlags        :: GlobalFlags+    , savedInitFlags          :: IT.InitFlags+    , savedInstallFlags       :: InstallFlags+    , savedClientInstallFlags :: ClientInstallFlags+    , savedConfigureFlags     :: ConfigFlags+    , savedConfigureExFlags   :: ConfigExFlags+    , savedUserInstallDirs    :: InstallDirs (Flag PathTemplate)+    , savedGlobalInstallDirs  :: InstallDirs (Flag PathTemplate)+    , savedUploadFlags        :: UploadFlags+    , savedReportFlags        :: ReportFlags+    , savedHaddockFlags       :: HaddockFlags+    , savedTestFlags          :: TestFlags+    , savedBenchmarkFlags     :: BenchmarkFlags+    , savedProjectFlags       :: ProjectFlags+    } deriving Generic++instance Monoid SavedConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup SavedConfig where+  a <> b = SavedConfig {+    savedGlobalFlags       = combinedSavedGlobalFlags,+    savedInitFlags         = combinedSavedInitFlags,+    savedInstallFlags      = combinedSavedInstallFlags,+    savedClientInstallFlags = combinedSavedClientInstallFlags,+    savedConfigureFlags    = combinedSavedConfigureFlags,+    savedConfigureExFlags  = combinedSavedConfigureExFlags,+    savedUserInstallDirs   = combinedSavedUserInstallDirs,+    savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,+    savedUploadFlags       = combinedSavedUploadFlags,+    savedReportFlags       = combinedSavedReportFlags,+    savedHaddockFlags      = combinedSavedHaddockFlags,+    savedTestFlags         = combinedSavedTestFlags,+    savedBenchmarkFlags    = combinedSavedBenchmarkFlags,+    savedProjectFlags      = combinedSavedProjectFlags+  }+    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)++      combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon)+                    -> mon+      combineMonoid 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'++      lastNonMempty'+        :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a+      lastNonMempty'   field subfield =+        let a' = subfield . field $ a+            b' = subfield . field $ b+        in if b' == mempty then a' else b'++      lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)+                      -> NubList a+      lastNonEmptyNL' field subfield =+        let a' = subfield . field $ a+            b' = subfield . field $ b+        in case fromNubList b' of [] -> a'+                                  _  -> b'++      combinedSavedGlobalFlags = GlobalFlags {+        globalVersion           = combine globalVersion,+        globalNumericVersion    = combine globalNumericVersion,+        globalConfigFile        = combine globalConfigFile,+        globalConstraintsFile   = combine globalConstraintsFile,+        globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,+        globalCacheDir          = combine globalCacheDir,+        globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,+        globalActiveRepos       = combine globalActiveRepos,+        globalLogsDir           = combine globalLogsDir,+        globalWorldFile         = combine globalWorldFile,+        globalIgnoreExpiry      = combine globalIgnoreExpiry,+        globalHttpTransport     = combine globalHttpTransport,+        globalNix               = combine globalNix,+        globalStoreDir          = combine globalStoreDir,+        globalProgPathExtra     = lastNonEmptyNL globalProgPathExtra+        }+        where+          combine        = combine'        savedGlobalFlags+          lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags++      combinedSavedInitFlags = IT.InitFlags {+        IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs,+        IT.author              = combine IT.author,+        IT.buildTools          = combineMonoid savedInitFlags IT.buildTools,+        IT.cabalVersion        = combine IT.cabalVersion,+        IT.category            = combine IT.category,+        IT.dependencies        = combineMonoid savedInitFlags IT.dependencies,+        IT.email               = combine IT.email,+        IT.exposedModules      = combineMonoid savedInitFlags IT.exposedModules,+        IT.extraSrc            = combineMonoid savedInitFlags IT.extraSrc,+        IT.homepage            = combine IT.homepage,+        IT.initHcPath          = combine IT.initHcPath,+        IT.initVerbosity       = combine IT.initVerbosity,+        IT.initializeTestSuite = combine IT.initializeTestSuite,+        IT.interactive         = combine IT.interactive,+        IT.language            = combine IT.language,+        IT.license             = combine IT.license,+        IT.mainIs              = combine IT.mainIs,+        IT.minimal             = combine IT.minimal,+        IT.noComments          = combine IT.noComments,+        IT.otherExts           = combineMonoid savedInitFlags IT.otherExts,+        IT.otherModules        = combineMonoid savedInitFlags IT.otherModules,+        IT.overwrite           = combine IT.overwrite,+        IT.packageDir          = combine IT.packageDir,+        IT.packageName         = combine IT.packageName,+        IT.packageType         = combine IT.packageType,+        IT.quiet               = combine IT.quiet,+        IT.simpleProject       = combine IT.simpleProject,+        IT.sourceDirs          = combineMonoid savedInitFlags IT.sourceDirs,+        IT.synopsis            = combine IT.synopsis,+        IT.testDirs            = combineMonoid savedInitFlags IT.testDirs,+        IT.version             = combine IT.version+        }+        where+          combine = combine' savedInitFlags++      combinedSavedInstallFlags = InstallFlags {+        installDocumentation         = combine installDocumentation,+        installHaddockIndex          = combine installHaddockIndex,+        installDryRun                = combine installDryRun,+        installOnlyDownload          = combine installOnlyDownload,+        installDest                  = combine installDest,+        installMaxBackjumps          = combine installMaxBackjumps,+        installReorderGoals          = combine installReorderGoals,+        installCountConflicts        = combine installCountConflicts,+        installFineGrainedConflicts  = combine installFineGrainedConflicts,+        installMinimizeConflictSet   = combine installMinimizeConflictSet,+        installIndependentGoals      = combine installIndependentGoals,+        installShadowPkgs            = combine installShadowPkgs,+        installStrongFlags           = combine installStrongFlags,+        installAllowBootLibInstalls  = combine installAllowBootLibInstalls,+        installOnlyConstrained       = combine installOnlyConstrained,+        installReinstall             = combine installReinstall,+        installAvoidReinstalls       = combine installAvoidReinstalls,+        installOverrideReinstall     = combine installOverrideReinstall,+        installUpgradeDeps           = combine installUpgradeDeps,+        installOnly                  = combine installOnly,+        installOnlyDeps              = combine installOnlyDeps,+        installIndexState            = combine installIndexState,+        installRootCmd               = combine installRootCmd,+        installSummaryFile           = lastNonEmptyNL installSummaryFile,+        installLogFile               = combine installLogFile,+        installBuildReports          = combine installBuildReports,+        installReportPlanningFailure = combine installReportPlanningFailure,+        installSymlinkBinDir         = combine installSymlinkBinDir,+        installPerComponent          = combine installPerComponent,+        installOneShot               = combine installOneShot,+        installNumJobs               = combine installNumJobs,+        installKeepGoing             = combine installKeepGoing,+        installRunTests              = combine installRunTests,+        installOfflineMode           = combine installOfflineMode+        }+        where+          combine        = combine'        savedInstallFlags+          lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags++      combinedSavedClientInstallFlags = ClientInstallFlags+        { cinstInstallLibs     = combine cinstInstallLibs+        , cinstEnvironmentPath = combine cinstEnvironmentPath+        , cinstOverwritePolicy = combine cinstOverwritePolicy+        , cinstInstallMethod   = combine cinstInstallMethod+        , cinstInstalldir      = combine cinstInstalldir+        }+        where+          combine        = combine'        savedClientInstallFlags++      combinedSavedConfigureFlags = ConfigFlags {+        configArgs                = lastNonEmpty configArgs,+        configPrograms_           = configPrograms_ . savedConfigureFlags $ b,+        -- TODO: NubListify+        configProgramPaths        = lastNonEmpty configProgramPaths,+        -- TODO: NubListify+        configProgramArgs         = lastNonEmpty configProgramArgs,+        configProgramPathExtra    = lastNonEmptyNL configProgramPathExtra,+        configInstantiateWith     = lastNonEmpty configInstantiateWith,+        configHcFlavor            = combine configHcFlavor,+        configHcPath              = combine configHcPath,+        configHcPkg               = combine configHcPkg,+        configVanillaLib          = combine configVanillaLib,+        configProfLib             = combine configProfLib,+        configProf                = combine configProf,+        configSharedLib           = combine configSharedLib,+        configStaticLib           = combine configStaticLib,+        configDynExe              = combine configDynExe,+        configFullyStaticExe      = combine configFullyStaticExe,+        configProfExe             = combine configProfExe,+        configProfDetail          = combine configProfDetail,+        configProfLibDetail       = combine configProfLibDetail,+        -- TODO: NubListify+        configConfigureArgs       = lastNonEmpty configConfigureArgs,+        configOptimization        = combine configOptimization,+        configDebugInfo           = combine configDebugInfo,+        configProgPrefix          = combine configProgPrefix,+        configProgSuffix          = combine configProgSuffix,+        -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.+        configInstallDirs         =+          (configInstallDirs . savedConfigureFlags $ a)+          `mappend` (configInstallDirs . savedConfigureFlags $ b),+        configScratchDir          = combine configScratchDir,+        -- TODO: NubListify+        configExtraLibDirs        = lastNonEmpty configExtraLibDirs,+        -- TODO: NubListify+        configExtraFrameworkDirs  = lastNonEmpty configExtraFrameworkDirs,+        -- TODO: NubListify+        configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,+        configDeterministic       = combine configDeterministic,+        configIPID                = combine configIPID,+        configCID                 = combine configCID,+        configDistPref            = combine configDistPref,+        configCabalFilePath       = combine configCabalFilePath,+        configVerbosity           = combine configVerbosity,+        configUserInstall         = combine configUserInstall,+        -- TODO: NubListify+        configPackageDBs          = lastNonEmpty configPackageDBs,+        configGHCiLib             = combine configGHCiLib,+        configSplitSections       = combine configSplitSections,+        configSplitObjs           = combine configSplitObjs,+        configStripExes           = combine configStripExes,+        configStripLibs           = combine configStripLibs,+        -- TODO: NubListify+        configConstraints         = lastNonEmpty configConstraints,+        -- TODO: NubListify+        configDependencies        = lastNonEmpty configDependencies,+        -- TODO: NubListify+        configConfigurationsFlags = lastNonMempty configConfigurationsFlags,+        configTests               = combine configTests,+        configBenchmarks          = combine configBenchmarks,+        configCoverage            = combine configCoverage,+        configLibCoverage         = combine configLibCoverage,+        configExactConfiguration  = combine configExactConfiguration,+        configFlagError           = combine configFlagError,+        configRelocatable         = combine configRelocatable,+        configUseResponseFiles    = combine configUseResponseFiles,+        configAllowDependingOnPrivateLibs =+            combine configAllowDependingOnPrivateLibs+        }+        where+          combine        = combine'        savedConfigureFlags+          lastNonEmpty   = lastNonEmpty'   savedConfigureFlags+          lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags+          lastNonMempty  = lastNonMempty'  savedConfigureFlags++      combinedSavedConfigureExFlags = ConfigExFlags {+        configCabalVersion  = combine configCabalVersion,+        -- TODO: NubListify+        configExConstraints = lastNonEmpty configExConstraints,+        -- TODO: NubListify+        configPreferences   = lastNonEmpty configPreferences,+        configSolver        = combine configSolver,+        configAllowNewer    =+            combineMonoid savedConfigureExFlags configAllowNewer,+        configAllowOlder    =+            combineMonoid savedConfigureExFlags configAllowOlder,+        configWriteGhcEnvironmentFilesPolicy+                            = combine configWriteGhcEnvironmentFilesPolicy+        }+        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 {+        uploadCandidate   = combine uploadCandidate,+        uploadDoc         = combine uploadDoc,+        uploadUsername    = combine uploadUsername,+        uploadPassword    = combine uploadPassword,+        uploadPasswordCmd = combine uploadPasswordCmd,+        uploadVerbosity   = combine uploadVerbosity+        }+        where+          combine = combine' savedUploadFlags++      combinedSavedReportFlags = ReportFlags {+        reportUsername  = combine reportUsername,+        reportPassword  = combine reportPassword,+        reportVerbosity = combine reportVerbosity+        }+        where+          combine = combine' savedReportFlags++      combinedSavedHaddockFlags = HaddockFlags {+        -- TODO: NubListify+        haddockProgramPaths  = lastNonEmpty haddockProgramPaths,+        -- TODO: NubListify+        haddockProgramArgs   = lastNonEmpty haddockProgramArgs,+        haddockHoogle        = combine haddockHoogle,+        haddockHtml          = combine haddockHtml,+        haddockHtmlLocation  = combine haddockHtmlLocation,+        haddockForHackage    = combine haddockForHackage,+        haddockExecutables   = combine haddockExecutables,+        haddockTestSuites    = combine haddockTestSuites,+        haddockBenchmarks    = combine haddockBenchmarks,+        haddockForeignLibs   = combine haddockForeignLibs,+        haddockInternal      = combine haddockInternal,+        haddockCss           = combine haddockCss,+        haddockLinkedSource  = combine haddockLinkedSource,+        haddockQuickJump     = combine haddockQuickJump,+        haddockHscolourCss   = combine haddockHscolourCss,+        haddockContents      = combine haddockContents,+        haddockDistPref      = combine haddockDistPref,+        haddockKeepTempFiles = combine haddockKeepTempFiles,+        haddockVerbosity     = combine haddockVerbosity,+        haddockCabalFilePath = combine haddockCabalFilePath,+        haddockArgs          = lastNonEmpty haddockArgs+        }+        where+          combine      = combine'        savedHaddockFlags+          lastNonEmpty = lastNonEmpty'   savedHaddockFlags++      combinedSavedTestFlags = TestFlags {+        testDistPref    = combine testDistPref,+        testVerbosity   = combine testVerbosity,+        testHumanLog    = combine testHumanLog,+        testMachineLog  = combine testMachineLog,+        testShowDetails = combine testShowDetails,+        testKeepTix     = combine testKeepTix,+        testWrapper     = combine testWrapper,+        testFailWhenNoTestSuites = combine testFailWhenNoTestSuites,+        testOptions     = lastNonEmpty testOptions+        }+        where+          combine      = combine'        savedTestFlags+          lastNonEmpty = lastNonEmpty'   savedTestFlags++      combinedSavedBenchmarkFlags = BenchmarkFlags {+        benchmarkDistPref  = combine benchmarkDistPref,+        benchmarkVerbosity = combine benchmarkVerbosity,+        benchmarkOptions   = lastNonEmpty benchmarkOptions+        }+        where+          combine      = combine'        savedBenchmarkFlags+          lastNonEmpty = lastNonEmpty'   savedBenchmarkFlags++      combinedSavedProjectFlags = ProjectFlags+        { flagProjectFileName = combine flagProjectFileName+        , flagIgnoreProject   = combine flagIgnoreProject+        }+        where+          combine      = combine'        savedProjectFlags++--+-- * Default config+--++-- | These are the absolute basic defaults. The fields that must be+-- initialised. When we load the config from the file we layer the loaded+-- values over these ones, so any missing fields in the file take their values+-- from here.+--+baseSavedConfig :: IO SavedConfig+baseSavedConfig = do+  userPrefix <- getCabalDir+  cacheDir   <- defaultCacheDir+  logsDir    <- defaultLogsDir+  worldFile  <- defaultWorldFile+  return mempty {+    savedConfigureFlags  = mempty {+      configHcFlavor     = toFlag defaultCompiler,+      configUserInstall  = toFlag defaultUserInstall,+      configVerbosity    = toFlag normal+    },+    savedUserInstallDirs = mempty {+      prefix             = toFlag (toPathTemplate userPrefix)+    },+    savedGlobalFlags = mempty {+      globalCacheDir     = toFlag cacheDir,+      globalLogsDir      = toFlag logsDir,+      globalWorldFile    = toFlag worldFile+    }+  }++-- | This is the initial configuration that we write out to the config file+-- if the file does not exist (or the config we use if the file cannot be read+-- for some other reason). When the config gets loaded it gets layered on top+-- of 'baseSavedConfig' so we do not need to include it into the initial+-- values we save into the config file.+--+initialSavedConfig :: IO SavedConfig+initialSavedConfig = do+  cacheDir    <- defaultCacheDir+  logsDir     <- defaultLogsDir+  worldFile   <- defaultWorldFile+  extraPath   <- defaultExtraPath+  installPath <- defaultInstallPath+  return mempty {+    savedGlobalFlags     = mempty {+      globalCacheDir     = toFlag cacheDir,+      globalRemoteRepos  = toNubList [defaultRemoteRepo],+      globalWorldFile    = toFlag worldFile+    },+    savedConfigureFlags  = mempty {+      configProgramPathExtra = toNubList extraPath+    },+    savedInstallFlags    = mempty {+      installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],+      installBuildReports= toFlag NoReports,+      installNumJobs     = toFlag Nothing+    },+    savedClientInstallFlags = mempty {+      cinstInstalldir = toFlag installPath+    }+  }++defaultCabalDir :: IO FilePath+defaultCabalDir = getAppUserDataDirectory "cabal"++getCabalDir :: IO FilePath+getCabalDir = do+  mDir <- lookupEnv "CABAL_DIR"+  case mDir of+    Nothing -> defaultCabalDir+    Just dir -> return dir++defaultConfigFile :: IO FilePath+defaultConfigFile = do+  dir <- getCabalDir+  return $ dir </> "config"++defaultCacheDir :: IO FilePath+defaultCacheDir = do+  dir <- getCabalDir+  return $ dir </> "packages"++defaultLogsDir :: IO FilePath+defaultLogsDir = do+  dir <- getCabalDir+  return $ dir </> "logs"++-- | Default position of the world file+defaultWorldFile :: IO FilePath+defaultWorldFile = do+  dir <- getCabalDir+  return $ dir </> "world"++defaultExtraPath :: IO [FilePath]+defaultExtraPath = do+  dir <- getCabalDir+  return [dir </> "bin"]++defaultInstallPath :: IO FilePath+defaultInstallPath = do+  dir <- getCabalDir+  return (dir </> "bin")++defaultCompiler :: CompilerFlavor+defaultCompiler = fromMaybe GHC defaultCompilerFlavor++defaultUserInstall :: Bool+defaultUserInstall = True+-- We do per-user installs by default on all platforms. We used to default to+-- global installs on Windows but that no longer works on Windows Vista or 7.++defaultRemoteRepo :: RemoteRepo+defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False+  where+    str  = "hackage.haskell.org"+    name = RepoName str+    uri  = URI "http:" (Just (URIAuth "" str "")) "/" "" ""+    -- Note that lots of old ~/.cabal/config files will have the old url+    -- http://hackage.haskell.org/packages/archive+    -- but new config files can use the new url (without the /packages/archive)+    -- and avoid having to do a http redirect++-- For the default repo we know extra information, fill this in.+--+-- We need this because the 'defaultRemoteRepo' above is only used for the+-- first time when a config file is made. So for users with older config files+-- we might have only have older info. This lets us fill that in even for old+-- config files.+--+addInfoForKnownRepos :: RemoteRepo -> RemoteRepo+addInfoForKnownRepos repo+  | remoteRepoName repo == remoteRepoName defaultRemoteRepo+  = useSecure . tryHttps . fixOldURI $ repo+  where+    fixOldURI r+      | isOldHackageURI (remoteRepoURI r)+                  = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo }+      | otherwise = r++    tryHttps r = r { remoteRepoShouldTryHttps = True }++    useSecure r@RemoteRepo{+                  remoteRepoSecure       = secure,+                  remoteRepoRootKeys     = [],+                  remoteRepoKeyThreshold = 0+                } | secure /= Just False+            = r {+                -- Use hackage-security by default unless you opt-out with+                -- secure: False+                remoteRepoSecure       = Just True,+                remoteRepoRootKeys     = defaultHackageRemoteRepoKeys,+                remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold+              }+    useSecure r = r+addInfoForKnownRepos other = other++-- | The current hackage.haskell.org repo root keys that we ship with cabal.+---+-- This lets us bootstrap trust in this repo without user intervention.+-- These keys need to be periodically updated when new root keys are added.+-- See the root key procedures for details.+--+defaultHackageRemoteRepoKeys :: [String]+defaultHackageRemoteRepoKeys =+    [ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0",+      "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42",+      "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3",+      "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d",+      "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"+    ]++-- | The required threshold of root key signatures for hackage.haskell.org+--+defaultHackageRemoteRepoKeyThreshold :: Int+defaultHackageRemoteRepoKeyThreshold = 3++--+-- * Config file reading+--++-- | Loads the main configuration, and applies additional defaults to give the+-- effective configuration. To loads just what is actually in the config file,+-- use 'loadRawConfig'.+--+loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig+loadConfig verbosity configFileFlag = do+  config <- loadRawConfig verbosity configFileFlag+  extendToEffectiveConfig config++extendToEffectiveConfig :: SavedConfig -> IO SavedConfig+extendToEffectiveConfig config = do+  base <- baseSavedConfig+  let effective0   = base `mappend` config+      globalFlags0 = savedGlobalFlags effective0+      effective  = effective0 {+                     savedGlobalFlags = globalFlags0 {+                       globalRemoteRepos =+                         overNubList (map addInfoForKnownRepos)+                                     (globalRemoteRepos globalFlags0)+                     }+                   }+  return effective++-- | Like 'loadConfig' but does not apply any additional defaults, it just+-- loads what is actually in the config file. This is thus suitable for+-- comparing or editing a config file, but not suitable for using as the+-- effective configuration.+--+loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig+loadRawConfig verbosity configFileFlag = do+  (source, configFile) <- getConfigFilePathAndSource configFileFlag+  minp <- readConfigFile mempty configFile+  case minp of+    Nothing -> do+      notice verbosity $+        "Config file path source is " ++ sourceMsg source ++ "."+      notice verbosity $ "Config file " ++ configFile ++ " not found."+      createDefaultConfigFile verbosity [] configFile+    Just (ParseOk ws conf) -> do+      unless (null ws) $ warn verbosity $+        unlines (map (showPWarning configFile) ws)+      return conf+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      die' verbosity $+          "Error parsing config file " ++ configFile+        ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg++  where+    sourceMsg CommandlineOption =   "commandline option"+    sourceMsg EnvironmentVariable = "env var CABAL_CONFIG"+    sourceMsg Default =             "default config file"++data ConfigFileSource = CommandlineOption+                      | EnvironmentVariable+                      | Default++-- | Returns the config file path, without checking that the file exists.+-- The order of precedence is: input flag, CABAL_CONFIG, default location.+getConfigFilePath :: Flag FilePath -> IO FilePath+getConfigFilePath = fmap snd . getConfigFilePathAndSource++getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)+getConfigFilePathAndSource configFileFlag =+    getSource sources+  where+    sources =+      [ (CommandlineOption,   return . flagToMaybe $ configFileFlag)+      , (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)+      , (Default,             Just `liftM` defaultConfigFile) ]++    getSource [] = error "no config file path candidate found."+    getSource ((source,action): xs) =+                      action >>= maybe (getSource xs) (return . (,) source)++readConfigFile+  :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))+readConfigFile initial file = handleNotExists $+  fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)+       (BS.readFile file)++  where+    handleNotExists action = catchIO action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig+createDefaultConfigFile verbosity extraLines filePath  = do+  commentConf <- commentSavedConfig+  initialConf <- initialSavedConfig+  extraConf   <- parseExtraLines verbosity extraLines+  notice verbosity $ "Writing default configuration to " ++ filePath+  writeConfigFile filePath commentConf (initialConf `mappend` extraConf)+  return initialConf++writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()+writeConfigFile file comments vals = do+  let tmpFile = file <.> "tmp"+  createDirectoryIfMissing True (takeDirectory file)+  writeFile tmpFile $+    explanation ++ showConfigWithComments comments vals ++ "\n"+  renameFile tmpFile file+  where+    explanation = unlines+      ["-- This is the configuration file for the 'cabal' command line tool."+      ,"--"+      ,"-- The available configuration options are listed below."+      ,"-- Some of them have default values listed."+      ,"--"+      ,"-- Lines (like this one) beginning with '--' are comments."+      ,"-- Be careful with spaces and indentation because they are"+      ,"-- used to indicate layout for nested sections."+      ,"--"+      ,"-- This config file was generated using the following versions"+      ,"-- of Cabal and cabal-install:"+      ,"-- Cabal library version: " ++ prettyShow cabalVersion+      ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion+      ,"",""+      ]++-- | These are the default values that get used in Cabal if a no value is+-- given. We use these here to include in comments when we write out the+-- initial config file so that the user can see what default value they are+-- overriding.+--+commentSavedConfig :: IO SavedConfig+commentSavedConfig = do+  userInstallDirs   <- defaultInstallDirs defaultCompiler True True+  globalInstallDirs <- defaultInstallDirs defaultCompiler False True+  let conf0 = mempty {+        savedGlobalFlags       = defaultGlobalFlags {+            globalRemoteRepos = toNubList [defaultRemoteRepo]+            },+        savedInitFlags       = mempty {+            IT.interactive     = toFlag False,+            IT.cabalVersion    = toFlag IT.defaultCabalVersion,+            IT.language        = toFlag Haskell2010,+            IT.license         = NoFlag,+            IT.sourceDirs      = Just [IT.defaultSourceDir],+            IT.applicationDirs = Just [IT.defaultApplicationDir]+            },+        savedInstallFlags      = defaultInstallFlags,+        savedClientInstallFlags= defaultClientInstallFlags,+        savedConfigureExFlags  = defaultConfigExFlags {+            configAllowNewer     = Just (AllowNewer mempty),+            configAllowOlder     = Just (AllowOlder mempty)+            },+        savedConfigureFlags    = (defaultConfigFlags defaultProgramDb) {+            configUserInstall    = toFlag defaultUserInstall+            },+        savedUserInstallDirs   = fmap toFlag userInstallDirs,+        savedGlobalInstallDirs = fmap toFlag globalInstallDirs,+        savedUploadFlags       = commandDefaultFlags uploadCommand,+        savedReportFlags       = commandDefaultFlags reportCommand,+        savedHaddockFlags      = defaultHaddockFlags,+        savedTestFlags         = defaultTestFlags,+        savedBenchmarkFlags    = defaultBenchmarkFlags+        }+  conf1 <- extendToEffectiveConfig conf0+  let globalFlagsConf1 = savedGlobalFlags conf1+      conf2 = conf1 {+        savedGlobalFlags = globalFlagsConf1 {+            globalRemoteRepos = overNubList (map removeRootKeys)+                                (globalRemoteRepos globalFlagsConf1)+            }+        }+  return conf2+    where+      -- Most people don't want to see default root keys, so don't print them.+      removeRootKeys :: RemoteRepo -> RemoteRepo+      removeRootKeys r = r { remoteRepoRootKeys = [] }++-- | All config file fields.+--+configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]+configFieldDescriptions src =++     toSavedConfig liftGlobalFlag+       (commandOptions (globalCommand []) ParseArgs)+       ["version", "numeric-version", "config-file"] []++  ++ toSavedConfig liftConfigFlag+       (configureOptions ParseArgs)+       (["builddir", "constraint", "dependency", "ipid"]+        ++ map fieldName installDirsFields)++        -- This is only here because viewAsFieldDescr gives us a parser+        -- that only recognises 'ghc' etc, the case-sensitive flag names, not+        -- what the normal case-insensitive parser gives us.+       [simpleFieldParsec "compiler"+          (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag)+          configHcFlavor (\v flags -> flags { configHcFlavor = v })++        -- TODO: The following is a temporary fix. The "optimization"+        -- and "debug-info" fields are OptArg, and viewAsFieldDescr+        -- fails on that. Instead of a hand-written hackaged parser+        -- and printer, we should handle this case properly in the+        -- library.+       ,liftField configOptimization (\v flags ->+                                       flags { configOptimization = v }) $+        let name = "optimization" in+        FieldDescr name+          (\f -> case f of+                   Flag NoOptimisation      -> Disp.text "False"+                   Flag NormalOptimisation  -> Disp.text "True"+                   Flag MaximumOptimisation -> Disp.text "2"+                   _                        -> Disp.empty)+          (\line str _ -> case () of+           _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)+             |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)+             |  str == "0"     -> ParseOk [] (Flag NoOptimisation)+             |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)+             |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)+             | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)+             | lstr == "true"  -> ParseOk [caseWarning]+                                  (Flag NormalOptimisation)+             | otherwise       -> ParseFailed (NoParse name line)+             where+               lstr = lowercase str+               caseWarning = PWarning $+                 "The '" ++ name+                 ++ "' field is case sensitive, use 'True' or 'False'.")+       ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $+        let name = "debug-info" in+        FieldDescr name+          (\f -> case f of+                   Flag NoDebugInfo      -> Disp.text "False"+                   Flag MinimalDebugInfo -> Disp.text "1"+                   Flag NormalDebugInfo  -> Disp.text "True"+                   Flag MaximalDebugInfo -> Disp.text "3"+                   _                     -> Disp.empty)+          (\line str _ -> case () of+           _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)+             |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)+             |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)+             |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)+             |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)+             |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)+             | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)+             | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)+             | otherwise       -> ParseFailed (NoParse name line)+             where+               lstr = lowercase str+               caseWarning = PWarning $+                 "The '" ++ name+                 ++ "' field is case sensitive, use 'True' or 'False'.")+       ]++  ++ toSavedConfig liftConfigExFlag+       (configureExOptions ParseArgs src)+       []+       [let pkgs            = (Just . AllowOlder . RelaxDepsSome)+                              `fmap` parsecOptCommaList parsec+            parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)+                               `fmap` parsec) <|> pkgs+         in simpleFieldParsec "allow-older"+            (showRelaxDeps . fmap unAllowOlder) parseAllowOlder+            configAllowOlder (\v flags -> flags { configAllowOlder = v })+       ,let pkgs            = (Just . AllowNewer . RelaxDepsSome)+                              `fmap` parsecOptCommaList parsec+            parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)+                               `fmap` parsec) <|> pkgs+         in simpleFieldParsec "allow-newer"+            (showRelaxDeps . fmap unAllowNewer) parseAllowNewer+            configAllowNewer (\v flags -> flags { configAllowNewer = v })+       ]++  ++ toSavedConfig liftInstallFlag+       (installOptions ParseArgs)+       ["dry-run", "only", "only-dependencies", "dependencies-only"] []++  ++ toSavedConfig liftClientInstallFlag+       (clientInstallOptions ParseArgs)+       [] []++  ++ toSavedConfig liftUploadFlag+       (commandOptions uploadCommand ParseArgs)+       ["verbose", "check", "documentation", "publish"] []++  ++ toSavedConfig liftReportFlag+       (commandOptions reportCommand ParseArgs)+       ["verbose", "username", "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.++  ++ [ viewAsFieldDescr+       $ optionDistPref+       (configDistPref . savedConfigureFlags)+       (\distPref config ->+          config+          { savedConfigureFlags = (savedConfigureFlags config) {+               configDistPref = distPref }+          , savedHaddockFlags = (savedHaddockFlags config) {+               haddockDistPref = distPref }+          }+       )+       ParseArgs+     ]++  where+    toSavedConfig lift options exclusions replacements =+      [ lift (fromMaybe field replacement)+      | opt <- options+      , let field       = viewAsFieldDescr opt+            name        = fieldName field+            replacement = find ((== name) . fieldName) replacements+      , name `notElem` exclusions ]++    showRelaxDeps Nothing                     = mempty+    showRelaxDeps (Just rd) | isRelaxDeps rd  = Disp.text "True"+                            | otherwise       = Disp.text "False"++    toRelaxDeps True  = RelaxDepsAll+    toRelaxDeps False = mempty+++-- TODO: next step, make the deprecated fields elicit a warning.+--+deprecatedFieldDescriptions :: [FieldDescr SavedConfig]+deprecatedFieldDescriptions =+  [ liftGlobalFlag $+    listFieldParsec "repos"+      pretty parsec+      (fromNubList . globalRemoteRepos)+      (\rs cfg -> cfg { globalRemoteRepos = toNubList rs })+  , liftGlobalFlag $+    simpleFieldParsec "cachedir"+      (Disp.text . fromFlagOrDefault "") (optionalFlag parsecFilePath)+      globalCacheDir    (\d cfg -> cfg { globalCacheDir = d })+  , liftUploadFlag $+    simpleFieldParsec "hackage-username"+      (Disp.text . fromFlagOrDefault "" . fmap unUsername)+      (optionalFlag (fmap Username parsecToken))+      uploadUsername    (\d cfg -> cfg { uploadUsername = d })+  , liftUploadFlag $+    simpleFieldParsec "hackage-password"+      (Disp.text . fromFlagOrDefault "" . fmap unPassword)+      (optionalFlag (fmap Password parsecToken))+      uploadPassword    (\d cfg -> cfg { uploadPassword = d })+  , liftUploadFlag $+    spaceListField "hackage-password-command"+      Disp.text parseTokenQ+      (fromFlagOrDefault [] . uploadPasswordCmd)+                        (\d cfg -> cfg { uploadPasswordCmd = Flag d })+  ]+ ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)+    installDirsFields+ ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs)+    installDirsFields+  where+    optionalFlag :: ParsecParser a -> ParsecParser (Flag a)+    optionalFlag p = toFlag <$> p <|> pure mempty++    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a+    modifyFieldName f d = d { fieldName = f (fieldName d) }++liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                    -> FieldDescr SavedConfig+liftUserInstallDirs = liftField+  savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })++liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                      -> FieldDescr SavedConfig+liftGlobalInstallDirs =+  liftField savedGlobalInstallDirs+  (\flags conf -> conf { savedGlobalInstallDirs = flags })++liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig+liftGlobalFlag = liftField+  savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })++liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig+liftConfigFlag = liftField+  savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })++liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig+liftConfigExFlag = liftField+  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })++liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig+liftInstallFlag = liftField+  savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })++liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig+liftClientInstallFlag =+  liftField savedClientInstallFlags+  (\flags conf -> conf { savedClientInstallFlags = flags })++liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig+liftUploadFlag = liftField+  savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })++liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig+liftReportFlag = liftField+  savedReportFlags (\flags conf -> conf { savedReportFlags = flags })++parseConfig :: ConstraintSource+            -> SavedConfig+            -> BS.ByteString+            -> ParseResult SavedConfig+parseConfig src initial = \str -> do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  config <- parse others+  let init0   = savedInitFlags config+      user0   = savedUserInstallDirs config+      global0 = savedGlobalInstallDirs config+  (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <-+    foldM parseSections+          ([], [], savedHaddockFlags config, init0, user0, global0, [], [])+          knownSections++  let remoteRepoSections =+          reverse+        . nubBy ((==) `on` remoteRepoName)+        $ remoteRepoSections0++  let localRepoSections =+          reverse+        . nubBy ((==) `on` localRepoName)+        $ localRepoSections0++  return . fixConfigMultilines $ config {+    savedGlobalFlags       = (savedGlobalFlags config) {+       globalRemoteRepos   = toNubList remoteRepoSections,+       globalLocalNoIndexRepos = toNubList localRepoSections,+       -- the global extra prog path comes from the configure flag prog path+       globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)+       },+    savedConfigureFlags    = (savedConfigureFlags config) {+       configProgramPaths  = paths,+       configProgramArgs   = args+       },+    savedHaddockFlags      = haddockFlags,+    savedInitFlags         = initFlags,+    savedUserInstallDirs   = user,+    savedGlobalInstallDirs = global+  }++  where+    isKnownSection (ParseUtils.Section _ "repository" _ _)              = True+    isKnownSection (ParseUtils.F _ "remote-repo" _)                     = True+    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True+    isKnownSection (ParseUtils.Section _ "init" _ _)                    = True+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True+    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True+    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True+    isKnownSection _                                                    = False++    -- Attempt to split fields that can represent lists of paths into+    -- actual lists on failure, leave the field untouched.+    splitMultiPath :: [String] -> [String]+    splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of+            ParseOk _ res -> res+            _ -> [s]+    splitMultiPath xs = xs++    -- This is a fixup, pending a full config parser rewrite, to+    -- ensure that config fields which can be comma-separated lists+    -- actually parse as comma-separated lists.+    fixConfigMultilines conf = conf {+         savedConfigureFlags =+           let scf = savedConfigureFlags conf+           in  scf {+                     configProgramPathExtra   =+                       toNubList $ splitMultiPath+                       (fromNubList $ configProgramPathExtra scf)+                   , configExtraLibDirs       = splitMultiPath+                                                (configExtraLibDirs scf)+                   , configExtraFrameworkDirs = splitMultiPath+                                                (configExtraFrameworkDirs scf)+                   , configExtraIncludeDirs   = splitMultiPath+                                                (configExtraIncludeDirs scf)+                   , configConfigureArgs      = splitMultiPath+                                                (configConfigureArgs scf)+               }+      }++    parse = parseFields (configFieldDescriptions src+                      ++ deprecatedFieldDescriptions) initial++    parseSections (rs, ls, h, i, u, g, p, a)+                 (ParseUtils.Section lineno "repository" name fs) = do+      name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $+          simpleParsec name+      r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs+      r'' <- postProcessRepo lineno name r'+      case r'' of+          Left local   -> return (rs,        local:ls, h, i, u, g, p, a)+          Right remote -> return (remote:rs, ls,       h, i, u, g, p, a)++    parseSections (rs, ls, h, i, u, g, p, a)+                 (ParseUtils.F lno "remote-repo" raw) = do+      let mr' = simpleParsec raw+      r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'+      return (r':rs, ls, h, i, u, g, p, a)++    parseSections accum@(rs, ls, h, i, u, g, p, a)+                 (ParseUtils.Section _ "haddock" name fs)+      | name == ""        = do h' <- parseFields haddockFlagsFields h fs+                               return (rs, ls, h', i, u, g, p, a)+      | otherwise         = do+          warning "The 'haddock' section should be unnamed"+          return accum++    parseSections accum@(rs, ls, h, i, u, g, p, a)+                 (ParseUtils.Section _ "init" name fs)+      | name == ""        = do i' <- parseFields initFlagsFields i fs+                               return (rs, ls, h, i', u, g, p, a)+      | otherwise         = do+          warning "The 'init' section should be unnamed"+          return accum++    parseSections accum@(rs, ls, h, i, u, g, p, a)+                  (ParseUtils.Section _ "install-dirs" name fs)+      | name' == "user"   = do u' <- parseFields installDirsFields u fs+                               return (rs, ls, h, i, u', g, p, a)+      | name' == "global" = do g' <- parseFields installDirsFields g fs+                               return (rs, ls, h, i, u, g', p, a)+      | otherwise         = do+          warning "The 'install-paths' section should be for 'user' or 'global'"+          return accum+      where name' = lowercase name+    parseSections accum@(rs, ls, h, i, u, g, p, a)+                 (ParseUtils.Section _ "program-locations" name fs)+      | name == ""        = do p' <- parseFields withProgramsFields p fs+                               return (rs, ls, h, i, u, g, p', a)+      | otherwise         = do+          warning "The 'program-locations' section should be unnamed"+          return accum+    parseSections accum@(rs, ls, h, i, u, g, p, a)+                  (ParseUtils.Section _ "program-default-options" name fs)+      | name == ""        = do a' <- parseFields withProgramOptionsFields a fs+                               return (rs, ls, h, i, u, g, 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++postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)+postProcessRepo lineno reponameStr repo0 = do+    when (null reponameStr) $+        syntaxError lineno $ "a 'repository' section requires the "+                          ++ "repository name as an argument"++    reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $+        simpleParsec reponameStr++    case uriScheme (remoteRepoURI repo0) of+        -- TODO: check that there are no authority, query or fragment+        -- Note: the trailing colon is important+        "file+noindex:" -> do+            let uri = remoteRepoURI repo0+            return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")++        _              -> do+            let repo = repo0 { remoteRepoName = reponame }++            when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $+                warning $ "'key-threshold' for repository "+                    ++ show (remoteRepoName repo)+                    ++ " higher than number of keys"++            when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $+                warning $ "'root-keys' for repository "+                    ++ show (remoteRepoName repo)+                    ++ " non-empty, but 'secure' not set to True."++            return $ Right repo++showConfig :: SavedConfig -> String+showConfig = showConfigWithComments mempty++showConfigWithComments :: SavedConfig -> SavedConfig -> String+showConfigWithComments comment vals = Disp.render $+      case fmap (uncurry ppRemoteRepoSection)+           (zip (getRemoteRepos comment) (getRemoteRepos vals)) of+        [] -> Disp.text ""+        (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs+  $+$ Disp.text ""+  $+$ ppFields+      (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))+      mcomment vals+  $+$ Disp.text ""+  $+$ ppSection "haddock" "" haddockFlagsFields+                (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)+  $+$ Disp.text ""+  $+$ ppSection "init" "" initFlagsFields+                (fmap savedInitFlags mcomment) (savedInitFlags vals)+  $+$ Disp.text ""+  $+$ installDirsSection "user"   savedUserInstallDirs+  $+$ Disp.text ""+  $+$ installDirsSection "global" savedGlobalInstallDirs+  $+$ Disp.text ""+  $+$ configFlagsSection "program-locations" withProgramsFields+                         configProgramPaths+  $+$ Disp.text ""+  $+$ configFlagsSection "program-default-options" withProgramOptionsFields+                         configProgramArgs+  where+    getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags+    mcomment = Just comment+    installDirsSection name field =+      ppSection "install-dirs" name installDirsFields+                (fmap field mcomment) (field vals)+    configFlagsSection name fields field =+      ppSection name "" fields+               (fmap (field . savedConfigureFlags) mcomment)+               ((field . savedConfigureFlags) vals)++    -- skip fields based on field name.  currently only skips "remote-repo",+    -- because that is rendered as a section.  (see 'ppRemoteRepoSection'.)+    skipSomeFields = filter ((/= "remote-repo") . fieldName)++-- | Fields for the 'install-dirs' sections.+installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]+installDirsFields = map viewAsFieldDescr installDirsOptions++ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc+ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))+    remoteRepoFields (Just def) vals++remoteRepoFields :: [FieldDescr RemoteRepo]+remoteRepoFields =+  [ simpleField "url"+    (text . show)            (parseTokenQ >>= parseURI')+    remoteRepoURI            (\x repo -> repo { remoteRepoURI = x })+  , simpleFieldParsec "secure"+    showSecure               (Just `fmap` parsec)+    remoteRepoSecure         (\x repo -> repo { remoteRepoSecure = x })+  , listField "root-keys"+    text                     parseTokenQ+    remoteRepoRootKeys       (\x repo -> repo { remoteRepoRootKeys = x })+  , simpleFieldParsec "key-threshold"+    showThreshold            P.integral+    remoteRepoKeyThreshold   (\x repo -> repo { remoteRepoKeyThreshold = x })+  ]+  where+    parseURI' uriString =+      case parseURI uriString of+        Nothing  -> fail $ "remote-repo: no parse on " ++ show uriString+        Just uri -> return uri++    showSecure  Nothing      = mempty       -- default 'secure' setting+    showSecure  (Just True)  = text "True"  -- user explicitly enabled it+    showSecure  (Just False) = text "False" -- user explicitly disabled it++    -- If the key-threshold is set to 0, we omit it as this is the default+    -- and it looks odd to have a value for key-threshold but not for 'secure'+    -- (note that an empty list of keys is already omitted by default, since+    -- that is what we do for all list fields)+    showThreshold 0 = mempty+    showThreshold t = text (show t)++-- | 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", "for-hackage"]++-- | Fields for the 'init' section.+initFlagsFields :: [FieldDescr IT.InitFlags]+initFlagsFields = [ field+                  | opt <- initOptions ParseArgs+                  , let field = viewAsFieldDescr opt+                        name  = fieldName field+                  , name `notElem` exclusions ]+  where+    exclusions =+      [ "author", "email", "quiet", "no-comments", "minimal", "overwrite"+      , "package-dir", "packagedir", "package-name", "version", "homepage"+      , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe"+      , "simple", "main-is", "expose-module", "exposed-modules", "extension"+      , "dependency", "build-tool", "with-compiler"+      , "verbose"+      ]++-- | Fields for the 'program-locations' section.+withProgramsFields :: [FieldDescr [(String, FilePath)]]+withProgramsFields =+  map viewAsFieldDescr $+  programDbPaths' (++ "-location") defaultProgramDb+                             ParseArgs id (++)++-- | Fields for the 'program-default-options' section.+withProgramOptionsFields :: [FieldDescr [(String, [String])]]+withProgramOptionsFields =+  map viewAsFieldDescr $+  programDbOptions defaultProgramDb ParseArgs id (++)++parseExtraLines :: Verbosity -> [String] -> IO SavedConfig+parseExtraLines verbosity extraLines =+  case parseConfig (ConstraintSourceMainConfig "additional lines")+       mempty (toUTF8BS (unlines extraLines)) of+    ParseFailed err ->+      let (line, msg) = locatedErrorMsg err+      in die' verbosity $+         "Error parsing additional config lines\n"+         ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+    ParseOk [] r -> return r+    ParseOk ws _ ->+      die' verbosity $+      unlines (map (showPWarning "Error parsing additional config lines") ws)++-- | Get the differences (as a pseudo code diff) between the user's+-- '~/.cabal/config' and the one that cabal would generate if it didn't exist.+userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String]+userConfigDiff verbosity globalFlags extraLines = do+  userConfig <- loadRawConfig normal (globalConfigFile globalFlags)+  extraConfig <- parseExtraLines verbosity extraLines+  testConfig <- initialSavedConfig+  return $+    reverse . foldl' createDiff [] . M.toList+    $ M.unionWith combine+      (M.fromList . map justFst $ filterShow testConfig)+      (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))+  where+    justFst (a, b) = (a, (Just b, Nothing))+    justSnd (a, b) = (a, (Nothing, Just b))++    combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)+    combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)+    combine x y = error $ "Can't happen : userConfigDiff "+                  ++ show x ++ " " ++ show y++    createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]+    createDiff acc (key, (Just a, Just b))+        | a == b = acc+        | otherwise = ("+ " ++ key ++ ": " ++ b)+                      : ("- " ++ key ++ ": " ++ a) : acc+    createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc+    createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc+    createDiff acc (_, (Nothing, Nothing)) = acc++    filterShow :: SavedConfig -> [(String, String)]+    filterShow cfg = map keyValueSplit+        . filter (\s -> not (null s) && ':' `elem` s)+        . map nonComment+        . lines+        $ showConfig cfg++    nonComment [] = []+    nonComment ('-':'-':_) = []+    nonComment (x:xs) = x : nonComment xs++    topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace++    keyValueSplit s =+        let (left, right) = break (== ':') s+        in (topAndTail left, topAndTail (drop 1 right))+++-- | Update the user's ~/.cabal/config' keeping the user's customizations.+userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()+userConfigUpdate verbosity globalFlags extraLines = do+  userConfig  <- loadRawConfig normal (globalConfigFile globalFlags)+  extraConfig <- parseExtraLines verbosity extraLines+  newConfig   <- initialSavedConfig+  commentConf <- commentSavedConfig+  cabalFile <- getConfigFilePath $ globalConfigFile globalFlags+  let backup = cabalFile ++ ".backup"+  notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."+  renameFile cabalFile backup+  notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."+  writeConfigFile cabalFile commentConf+    (newConfig `mappend` userConfig `mappend` extraConfig)
+ src/Distribution/Client/Configure.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Configure+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Duncan Coutts 2005+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- High level interface to configuring a package.+-----------------------------------------------------------------------------+module Distribution.Client.Configure (+    configure,+    configureSetupScript,+    chooseCabalVersion,+    checkConfigExFlags,+    -- * Saved configure flags+    readConfigFlagsFrom, readConfigFlags,+    cabalConfigFlagsFile,+    writeConfigFlagsTo, writeConfigFlags,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic (safeHead)++import Distribution.Client.Dependency+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.Setup+         ( ConfigExFlags(..), RepoContext(..)+         , configureCommand, configureExCommand, filterConfigureFlags )+import Distribution.Client.Types as Source+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Targets+         ( userToPackageConstraint, userConstraintPackageName )+import Distribution.Client.JobControl (Lock)++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageIndex+                   ( PackageIndex, elemByPackageName )+import           Distribution.Solver.Types.PkgConfigDb+                   (PkgConfigDb, readPkgConfigDb)+import           Distribution.Solver.Types.SourcePackage++import Distribution.Simple.Compiler+         ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program (ProgramDb)+import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags )+import Distribution.Simple.Setup+         ( ConfigFlags(..)+         , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Simple.PackageIndex+         ( InstalledPackageIndex, lookupPackageName )+import Distribution.Package+         ( Package(..), packageName, PackageId )+import Distribution.Types.GivenComponent+         ( GivenComponent(..) )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint(..), thisPackageVersionConstraint )+import qualified Distribution.PackageDescription as PkgDesc+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePD )+import Distribution.Version+         ( Version, mkVersion, anyVersion, thisVersion+         , VersionRange, orLaterVersion )+import Distribution.Simple.Utils as Utils+         ( warn, notice, debug, die'+         , defaultPackageDesc )+import Distribution.System+         ( Platform )++import System.FilePath ( (</>) )++-- | 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+    -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed+    -- for '--allow-newer' to work.+    allowNewer = isRelaxDeps+                 (maybe mempty unAllowNewer $ configAllowNewer configExFlags)+    allowOlder = isRelaxDeps+                 (maybe mempty unAllowOlder $ configAllowOlder configExFlags)++    defaultVersionRange = if allowOlder || allowNewer+                          then orLaterVersion (mkVersion [1,19,2])+                          else anyVersion++-- | Configure the package found in the local directory+configure :: Verbosity+          -> PackageDBStack+          -> RepoContext+          -> Compiler+          -> Platform+          -> ProgramDb+          -> ConfigFlags+          -> ConfigExFlags+          -> [String]+          -> IO ()+configure verbosity packageDBs repoCtxt comp platform progdb+  configFlags configExFlags extraArgs = do++  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+  sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+  pkgConfigDb       <- readPkgConfigDb      verbosity progdb++  checkConfigExFlags verbosity installedPkgIndex+                     (packageIndex sourcePkgDb) configExFlags++  progress <- planLocalPackage verbosity comp platform configFlags configExFlags+                               installedPkgIndex sourcePkgDb pkgConfigDb++  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress logMsg (return . Left) (return . Right)+                            progress+  case maybePlan of+    Left message -> do+      warn verbosity $+           "solver failed to find a solution:\n"+        ++ message+        ++ "\nTrying configure anyway."+      setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)+        Nothing configureCommand (const configFlags) (const extraArgs)++    Right installPlan0 ->+     let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0+     in case fst (InstallPlan.ready installPlan) of+      [pkg@(ReadyPackage+              (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)+                                 _ _ _))] -> do+        configurePackage verbosity+          platform (compilerInfo comp)+          (setupScriptOptions installedPkgIndex (Just pkg))+          configFlags pkg extraArgs++      _ -> die' verbosity $ "internal error: configure install plan should have exactly "+              ++ "one local ready package."++  where+    setupScriptOptions :: InstalledPackageIndex+                       -> Maybe ReadyPackage+                       -> SetupScriptOptions+    setupScriptOptions =+      configureSetupScript+        packageDBs+        comp+        platform+        progdb+        (fromFlagOrDefault+           (useDistPref defaultSetupScriptOptions)+           (configDistPref configFlags))+        (chooseCabalVersion+           configExFlags+           (flagToMaybe (configCabalVersion configExFlags)))+        Nothing+        False++    logMsg message rest = debug verbosity message >> rest++configureSetupScript :: PackageDBStack+                     -> Compiler+                     -> Platform+                     -> ProgramDb+                     -> FilePath+                     -> VersionRange+                     -> Maybe Lock+                     -> Bool+                     -> InstalledPackageIndex+                     -> Maybe ReadyPackage+                     -> SetupScriptOptions+configureSetupScript packageDBs+                     comp+                     platform+                     progdb+                     distPref+                     cabalVersion+                     lock+                     forceExternal+                     index+                     mpkg+  = SetupScriptOptions {+      useCabalVersion          = cabalVersion+    , useCabalSpecVersion      = Nothing+    , useCompiler              = Just comp+    , usePlatform              = Just platform+    , usePackageDB             = packageDBs'+    , usePackageIndex          = index'+    , useProgramDb             = progdb+    , useDistPref              = distPref+    , useLoggingHandle         = Nothing+    , useWorkingDir            = Nothing+    , useExtraPathEnv          = []+    , useExtraEnvOverrides     = []+    , setupCacheLock           = lock+    , useWin32CleanHack        = False+    , forceExternalSetupMethod = forceExternal+      -- If we have explicit setup dependencies, list them; otherwise, we give+      -- the empty list of dependencies; ideally, we would fix the version of+      -- Cabal here, so that we no longer need the special case for that in+      -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet+      -- know the version of Cabal at this point, but only find this there.+      -- Therefore, for now, we just leave this blank.+    , useDependencies          = fromMaybe [] explicitSetupDeps+    , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps+    , useVersionMacros         = not defaultSetupDeps && isJust explicitSetupDeps+    , isInteractive            = False+    }+  where+    -- When we are compiling a legacy setup script without an explicit+    -- setup stanza, we typically want to allow the UserPackageDB for+    -- finding the Cabal lib when compiling any Setup.hs even if we're doing+    -- a global install. However we also allow looking in a specific package+    -- db.+    packageDBs' :: PackageDBStack+    index'      :: Maybe InstalledPackageIndex+    (packageDBs', index') =+      case packageDBs of+        (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs+                              , Nothing <- explicitSetupDeps+            -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)+        -- but if the user is using an odd db stack, don't touch it+        _otherwise -> (packageDBs, Just index)++    maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo+    maybeSetupBuildInfo = do+      ReadyPackage cpkg <- mpkg+      let gpkg = srcpkgDescription (confPkgSource cpkg)+      PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)++    -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If+    -- so, 'setup-depends' must not be exclusive. See #3199.+    defaultSetupDeps :: Bool+    defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends+                       maybeSetupBuildInfo++    explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]+    explicitSetupDeps = do+      -- Check if there is an explicit setup stanza.+      _buildInfo <- maybeSetupBuildInfo+      -- Return the setup dependencies computed by the solver+      ReadyPackage cpkg <- mpkg+      return [ ( cid, srcid )+             | ConfiguredId srcid+               (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid+                 <- CD.setupDeps (confPkgDeps cpkg)+             ]++-- | Warn if any constraints or preferences name packages that are not in the+-- source package index or installed package index.+checkConfigExFlags :: Package pkg+                   => Verbosity+                   -> InstalledPackageIndex+                   -> PackageIndex pkg+                   -> ConfigExFlags+                   -> IO ()+checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do+  for_ (safeHead unknownConstraints) $ \h ->+    warn verbosity $ "Constraint refers to an unknown package: "+          ++ showConstraint h+  for_ (safeHead unknownPreferences) $ \h ->+    warn verbosity $ "Preference refers to an unknown package: "+          ++ prettyShow h+  where+    unknownConstraints = filter (unknown . userConstraintPackageName . fst) $+                         configExConstraints flags+    unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $+                         configPreferences flags+    unknown pkg = null (lookupPackageName installedPkgIndex pkg)+               && not (elemByPackageName sourcePkgIndex pkg)+    showConstraint (uc, src) =+        prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"++-- | Make an 'InstallPlan' for the unpacked package in the current directory,+-- and all its dependencies.+--+planLocalPackage :: Verbosity -> Compiler+                 -> Platform+                 -> ConfigFlags -> ConfigExFlags+                 -> InstalledPackageIndex+                 -> SourcePackageDb+                 -> PkgConfigDb+                 -> IO (Progress String String SolverInstallPlan)+planLocalPackage verbosity comp platform configFlags configExFlags+  installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do+  pkg <- readGenericPackageDescription verbosity =<<+            case flagToMaybe (configCabalFilePath configFlags) of+                Nothing -> defaultPackageDesc verbosity+                Just fp -> return fp+  solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)+            (compilerInfo comp)++  let -- We create a local package and ask to resolve a dependency on it+      localPkg = SourcePackage {+        srcpkgPackageId          = packageId pkg,+        srcpkgDescription        = pkg,+        srcpkgSource             = LocalUnpackedPackage ".",+        srcpkgDescrOverride      = Nothing+      }++      testsEnabled = fromFlagOrDefault False $ configTests configFlags+      benchmarksEnabled =+        fromFlagOrDefault False $ configBenchmarks configFlags++      resolverParams =+          removeLowerBounds+          (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)+        . removeUpperBounds+          (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)++        . addPreferences+            -- preferences from the config file or command line+            [ PackageVersionPreference name ver+            | PackageVersionConstraint 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.+            [ LabeledPackageConstraint (userToPackageConstraint uc) src+            | (uc, src) <- configExConstraints configExFlags ]++        . addConstraints+            -- package flags from the config file or command line+            [ let pc = PackageConstraint+                       (scopeToplevel $ packageName pkg)+                       (PackagePropertyFlags $ configConfigurationsFlags configFlags)+              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+            ]++        . addConstraints+            -- '--enable-tests' and '--enable-benchmarks' constraints from+            -- the config file or command line+            [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .+                       PackagePropertyStanzas $+                       [ TestStanzas  | testsEnabled ] +++                       [ BenchStanzas | benchmarksEnabled ]+              in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+            ]++            -- Don't solve for executables, since we use an empty source+            -- package database and executables never show up in the+            -- installed package index+        . setSolveExecutables (SolveExecutables False)++        . setSolverVerbosity verbosity++        $ standardInstallPolicy+            installedPkgIndex+            -- NB: We pass in an *empty* source package database,+            -- because cabal configure assumes that all dependencies+            -- have already been installed+            (SourcePackageDb mempty packagePrefs)+            [SpecificSourcePackage localPkg]++  return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)+++-- | Call an installer for an 'SourcePackage' but override the configure+-- 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 -> CompilerInfo+                 -> SetupScriptOptions+                 -> ConfigFlags+                 -> ReadyPackage+                 -> [String]+                 -> IO ()+configurePackage verbosity platform comp scriptOptions configFlags+                 (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))+                 extraArgs =++  setupWrapper verbosity+    scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs)++  where+    gpkg = srcpkgDescription spkg+    configureFlags   = filterConfigureFlags configFlags {+      configIPID = if isJust (flagToMaybe (configIPID configFlags))+                    -- Make sure cabal configure --ipid works.+                    then configIPID configFlags+                    else toFlag (prettyShow ipid),+      configConfigurationsFlags = flags,+      -- 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  = [ thisPackageVersionConstraint srcid+                           | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid+                               <- CD.nonSetupDeps deps ],+      configDependencies = [ GivenComponent (packageName srcid) cname uid+                           | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid+                               <- CD.nonSetupDeps deps ],+      -- Use '--exact-configuration' if supported.+      configExactConfiguration = toFlag True,+      configVerbosity          = toFlag verbosity,+      -- NB: if the user explicitly specified+      -- --enable-tests/--enable-benchmarks, always respect it.+      -- (But if they didn't, let solver decide.)+      configBenchmarks         = toFlag (BenchStanzas `optStanzaSetMember` stanzas)+                                    `mappend` configBenchmarks configFlags,+      configTests              = toFlag (TestStanzas `optStanzaSetMember` stanzas)+                                    `mappend` configTests configFlags+    }++    pkg = case finalizePD flags (enableStanzas stanzas)+           (const True)+           platform comp [] gpkg of+      Left _ -> error "finalizePD ReadyPackage failed"+      Right (desc, _) -> desc++-- -----------------------------------------------------------------------------+-- * Saved configure environments and flags+-- -----------------------------------------------------------------------------++-- | Read saved configure flags and restore the saved environment from the+-- specified files.+readConfigFlagsFrom :: FilePath  -- ^ path to saved flags file+                    -> IO (ConfigFlags, ConfigExFlags)+readConfigFlagsFrom flags = do+  readCommandFlags flags configureExCommand++-- | The path (relative to @--build-dir@) where the arguments to @configure@+-- should be saved.+cabalConfigFlagsFile :: FilePath -> FilePath+cabalConfigFlagsFile dist = dist </> "cabal-config-flags"++-- | Read saved configure flags and restore the saved environment from the+-- usual location.+readConfigFlags :: FilePath  -- ^ @--build-dir@+                -> IO (ConfigFlags, ConfigExFlags)+readConfigFlags dist =+  readConfigFlagsFrom (cabalConfigFlagsFile dist)++-- | Save the configure flags and environment to the specified files.+writeConfigFlagsTo :: FilePath  -- ^ path to saved flags file+                   -> Verbosity -> (ConfigFlags, ConfigExFlags)+                   -> IO ()+writeConfigFlagsTo file verb flags = do+  writeCommandFlags verb file configureExCommand flags++-- | Save the build flags to the usual location.+writeConfigFlags :: Verbosity+                 -> FilePath  -- ^ @--build-dir@+                 -> (ConfigFlags, ConfigExFlags) -> IO ()+writeConfigFlags verb dist =+  writeConfigFlagsTo (cabalConfigFlagsFile dist) verb
+ src/Distribution/Client/Dependency.hs view
@@ -0,0 +1,1045 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Top level interface to dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency (+    -- * The main package dependency resolver+    chooseSolver,+    resolveDependencies,+    Progress(..),+    foldProgress,++    -- * Alternate, simple resolver that does not do dependencies recursively+    resolveWithoutDependencies,++    -- * Constructing resolver policies+    PackageProperty(..),+    PackageConstraint(..),+    scopeToplevel,+    PackagesPreferenceDefault(..),+    PackagePreference(..),++    -- ** Standard policy+    basicInstallPolicy,+    standardInstallPolicy,+    PackageSpecifier(..),++    -- ** Extra policy options+    upgradeDependencies,+    reinstallTargets,++    -- ** Policy utils+    addConstraints,+    addPreferences,+    setPreferenceDefault,+    setReorderGoals,+    setCountConflicts,+    setFineGrainedConflicts,+    setMinimizeConflictSet,+    setIndependentGoals,+    setAvoidReinstalls,+    setShadowPkgs,+    setStrongFlags,+    setAllowBootLibInstalls,+    setOnlyConstrained,+    setMaxBackjumps,+    setEnableBackjumping,+    setSolveExecutables,+    setGoalOrder,+    setSolverVerbosity,+    removeLowerBounds,+    removeUpperBounds,+    addDefaultSetupDependencies,+    addSetupCabalMinVersionConstraint,+    addSetupCabalMaxVersionConstraint,+  ) where++import Distribution.Client.Compat.Prelude+import qualified Prelude as Unsafe (head)++import Distribution.Solver.Modular+         ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) )+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import Distribution.Client.Types+         ( SourcePackageDb(SourcePackageDb)+         , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints+         , UnresolvedPkgLoc, UnresolvedSourcePackage+         , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..)+         , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps+         )+import Distribution.Client.Dependency.Types+         ( PreSolver(..), Solver(..)+         , PackagesPreferenceDefault(..) )+import Distribution.Package+         ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId+         , Package(..), packageName, packageVersion )+import Distribution.Types.Dependency+import qualified Distribution.PackageDescription as PD+import qualified Distribution.PackageDescription.Configuration as PD+import Distribution.PackageDescription.Configuration+         ( finalizePD )+import Distribution.Compiler+         ( CompilerInfo(..) )+import Distribution.System+         ( Platform )+import Distribution.Client.Utils+         ( duplicatesBy, mergeBy, MergeResult(..) )+import Distribution.Simple.Setup+         ( asBool )+import Distribution.Verbosity+         ( normal  )+import Distribution.Version+import qualified Distribution.Compat.Graph as Graph++import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.DependencyResolver+import           Distribution.Solver.Types.InstalledPreference+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import           Distribution.Solver.Types.PackagePath+import           Distribution.Solver.Types.PackagePreferences+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)+import           Distribution.Solver.Types.Progress+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Variable++import Data.List+         ( maximumBy )+import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Exception+         ( assert )+++-- ------------------------------------------------------------+-- * High level planner policy+-- ------------------------------------------------------------++-- | The set of parameters to the dependency resolver. These parameters are+-- relatively low level but many kinds of high level policies can be+-- implemented in terms of adjustments to the parameters.+--+data DepResolverParams = DepResolverParams {+       depResolverTargets           :: Set PackageName,+       depResolverConstraints       :: [LabeledPackageConstraint],+       depResolverPreferences       :: [PackagePreference],+       depResolverPreferenceDefault :: PackagesPreferenceDefault,+       depResolverInstalledPkgIndex :: InstalledPackageIndex,+       depResolverSourcePkgIndex    :: PackageIndex.PackageIndex UnresolvedSourcePackage,+       depResolverReorderGoals      :: ReorderGoals,+       depResolverCountConflicts    :: CountConflicts,+       depResolverFineGrainedConflicts :: FineGrainedConflicts,+       depResolverMinimizeConflictSet :: MinimizeConflictSet,+       depResolverIndependentGoals  :: IndependentGoals,+       depResolverAvoidReinstalls   :: AvoidReinstalls,+       depResolverShadowPkgs        :: ShadowPkgs,+       depResolverStrongFlags       :: StrongFlags,++       -- | Whether to allow base and its dependencies to be installed.+       depResolverAllowBootLibInstalls :: AllowBootLibInstalls,++       -- | Whether to only allow explicitly constrained packages plus+       -- goals or to allow any package.+       depResolverOnlyConstrained   :: OnlyConstrained,++       depResolverMaxBackjumps      :: Maybe Int,+       depResolverEnableBackjumping :: EnableBackjumping,+       -- | Whether or not to solve for dependencies on executables.+       -- This should be true, except in the legacy code path where+       -- we can't tell if an executable has been installed or not,+       -- so we shouldn't solve for them.  See #3875.+       depResolverSolveExecutables  :: SolveExecutables,++       -- | Function to override the solver's goal-ordering heuristics.+       depResolverGoalOrder         :: Maybe (Variable QPN -> Variable QPN -> Ordering),+       depResolverVerbosity         :: Verbosity+     }++showDepResolverParams :: DepResolverParams -> String+showDepResolverParams p =+     "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))+  ++ "\nconstraints: "+  ++   concatMap (("\n  " ++) . showLabeledConstraint)+       (depResolverConstraints p)+  ++ "\npreferences: "+  ++   concatMap (("\n  " ++) . showPackagePreference)+       (depResolverPreferences p)+  ++ "\nstrategy: "          ++ show (depResolverPreferenceDefault        p)+  ++ "\nreorder goals: "     ++ show (asBool (depResolverReorderGoals     p))+  ++ "\ncount conflicts: "   ++ show (asBool (depResolverCountConflicts   p))+  ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p))+  ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p))+  ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p))+  ++ "\navoid reinstalls: "  ++ show (asBool (depResolverAvoidReinstalls  p))+  ++ "\nshadow packages: "   ++ show (asBool (depResolverShadowPkgs       p))+  ++ "\nstrong flags: "      ++ show (asBool (depResolverStrongFlags      p))+  ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p))+  ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p)+  ++ "\nmax backjumps: "     ++ maybe "infinite" show+                                     (depResolverMaxBackjumps             p)+  where+    showLabeledConstraint :: LabeledPackageConstraint -> String+    showLabeledConstraint (LabeledPackageConstraint pc src) =+        showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"++-- | A package selection preference for a particular package.+--+-- Preferences are soft constraints that the dependency resolver should try to+-- respect where possible. It is not specified if preferences on some packages+-- are more important than others.+--+data PackagePreference =++     -- | A suggested constraint on the version number.+     PackageVersionPreference   PackageName VersionRange++     -- | If we prefer versions of packages that are already installed.+   | PackageInstalledPreference PackageName InstalledPreference++     -- | If we would prefer to enable these optional stanzas+     -- (i.e. test suites and/or benchmarks)+   | PackageStanzasPreference   PackageName [OptionalStanza]+++-- | Provide a textual representation of a package preference+-- for debugging purposes.+--+showPackagePreference :: PackagePreference -> String+showPackagePreference (PackageVersionPreference   pn vr) =+  prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr)+showPackagePreference (PackageInstalledPreference pn ip) =+  prettyShow pn ++ " " ++ show ip+showPackagePreference (PackageStanzasPreference pn st) =+  prettyShow pn ++ " " ++ show st++basicDepResolverParams :: InstalledPackageIndex+                       -> PackageIndex.PackageIndex UnresolvedSourcePackage+                       -> DepResolverParams+basicDepResolverParams installedPkgIndex sourcePkgIndex =+    DepResolverParams {+       depResolverTargets           = Set.empty,+       depResolverConstraints       = [],+       depResolverPreferences       = [],+       depResolverPreferenceDefault = PreferLatestForSelected,+       depResolverInstalledPkgIndex = installedPkgIndex,+       depResolverSourcePkgIndex    = sourcePkgIndex,+       depResolverReorderGoals      = ReorderGoals False,+       depResolverCountConflicts    = CountConflicts True,+       depResolverFineGrainedConflicts = FineGrainedConflicts True,+       depResolverMinimizeConflictSet = MinimizeConflictSet False,+       depResolverIndependentGoals  = IndependentGoals False,+       depResolverAvoidReinstalls   = AvoidReinstalls False,+       depResolverShadowPkgs        = ShadowPkgs False,+       depResolverStrongFlags       = StrongFlags False,+       depResolverAllowBootLibInstalls = AllowBootLibInstalls False,+       depResolverOnlyConstrained   = OnlyConstrainedNone,+       depResolverMaxBackjumps      = Nothing,+       depResolverEnableBackjumping = EnableBackjumping True,+       depResolverSolveExecutables  = SolveExecutables True,+       depResolverGoalOrder         = Nothing,+       depResolverVerbosity         = normal+     }++addTargets :: [PackageName]+           -> DepResolverParams -> DepResolverParams+addTargets extraTargets params =+    params {+      depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params+    }++addConstraints :: [LabeledPackageConstraint]+               -> DepResolverParams -> DepResolverParams+addConstraints extraConstraints params =+    params {+      depResolverConstraints = extraConstraints+                            ++ depResolverConstraints params+    }++addPreferences :: [PackagePreference]+               -> DepResolverParams -> DepResolverParams+addPreferences extraPreferences params =+    params {+      depResolverPreferences = extraPreferences+                            ++ depResolverPreferences params+    }++setPreferenceDefault :: PackagesPreferenceDefault+                     -> DepResolverParams -> DepResolverParams+setPreferenceDefault preferenceDefault params =+    params {+      depResolverPreferenceDefault = preferenceDefault+    }++setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams+setReorderGoals reorder params =+    params {+      depResolverReorderGoals = reorder+    }++setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams+setCountConflicts count params =+    params {+      depResolverCountConflicts = count+    }++setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams+setFineGrainedConflicts fineGrained params =+    params {+      depResolverFineGrainedConflicts = fineGrained+    }++setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams+setMinimizeConflictSet minimize params =+    params {+      depResolverMinimizeConflictSet = minimize+    }++setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams+setIndependentGoals indep params =+    params {+      depResolverIndependentGoals = indep+    }++setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams+setAvoidReinstalls avoid params =+    params {+      depResolverAvoidReinstalls = avoid+    }++setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams+setShadowPkgs shadow params =+    params {+      depResolverShadowPkgs = shadow+    }++setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams+setStrongFlags sf params =+    params {+      depResolverStrongFlags = sf+    }++setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams+setAllowBootLibInstalls i params =+    params {+      depResolverAllowBootLibInstalls = i+    }++setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams+setOnlyConstrained i params =+  params {+    depResolverOnlyConstrained = i+  }++setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams+setMaxBackjumps n params =+    params {+      depResolverMaxBackjumps = n+    }++setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams+setEnableBackjumping b params =+    params {+      depResolverEnableBackjumping = b+    }++setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams+setSolveExecutables b params =+    params {+      depResolverSolveExecutables = b+    }++setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)+             -> DepResolverParams+             -> DepResolverParams+setGoalOrder order params =+    params {+      depResolverGoalOrder = order+    }++setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams+setSolverVerbosity verbosity params =+    params {+      depResolverVerbosity = verbosity+    }++-- | Some packages are specific to a given compiler version and should never be+-- upgraded.+dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams+dontUpgradeNonUpgradeablePackages params =+    addConstraints extraConstraints params+  where+    extraConstraints =+      [ LabeledPackageConstraint+        (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled)+        ConstraintSourceNonUpgradeablePackage+      | Set.notMember (mkPackageName "base") (depResolverTargets params)+      -- If you change this enumeration, make sure to update the list in+      -- "Distribution.Solver.Modular.Solver" as well+      , pkgname <- [ mkPackageName "base"+                   , mkPackageName "ghc-bignum"+                   , mkPackageName "ghc-prim"+                   , mkPackageName "integer-gmp"+                   , mkPackageName "integer-simple"+                   , mkPackageName "template-haskell"+                   ]+      , isInstalled pkgname ]++    isInstalled = not . null+                . InstalledPackageIndex.lookupPackageName+                                 (depResolverInstalledPkgIndex params)++addSourcePackages :: [UnresolvedSourcePackage]+                  -> DepResolverParams -> DepResolverParams+addSourcePackages pkgs params =+    params {+      depResolverSourcePkgIndex =+        foldl (flip PackageIndex.insert)+              (depResolverSourcePkgIndex params) pkgs+    }++hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]+                                                  -> DepResolverParams+                                                  -> DepResolverParams+hideInstalledPackagesSpecificBySourcePackageId pkgids params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalledPkgIndex =+        foldl' (flip InstalledPackageIndex.deleteSourcePackageId)+               (depResolverInstalledPkgIndex params) pkgids+    }++hideInstalledPackagesAllVersions :: [PackageName]+                                 -> DepResolverParams -> DepResolverParams+hideInstalledPackagesAllVersions pkgnames params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalledPkgIndex =+        foldl' (flip InstalledPackageIndex.deletePackageName)+               (depResolverInstalledPkgIndex params) pkgnames+    }+++-- | Remove upper bounds in dependencies using the policy specified by the+-- 'AllowNewer' argument (all/some/none).+--+-- Note: It's important to apply 'removeUpperBounds' after+-- 'addSourcePackages'. Otherwise, the packages inserted by+-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.+--+removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams+removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps++-- | Dual of 'removeUpperBounds'+removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams+removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps++data RelaxKind = RelaxLower | RelaxUpper++-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'+removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams+removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation+removeBounds  relKind relDeps            params =+    params {+      depResolverSourcePkgIndex = sourcePkgIndex'+    }+  where+    sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params++    relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    relaxDeps srcPkg = srcPkg+      { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg)+      }++-- | Relax the dependencies of this package if needed.+--+-- Helper function used by 'removeBounds'+relaxPackageDeps :: RelaxKind+                 -> RelaxDeps+                 -> PD.GenericPackageDescription -> PD.GenericPackageDescription+relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'+relaxPackageDeps relKind RelaxDepsAll  gpd = PD.transformAllBuildDepends relaxAll gpd+  where+    relaxAll :: Dependency -> Dependency+    relaxAll (Dependency pkgName verRange cs) =+        Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs++relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =+  PD.transformAllBuildDepends relaxSome gpd+  where+    thisPkgName    = packageName gpd+    thisPkgId      = packageId   gpd+    depsToRelax    = Map.fromList $ mapMaybe f depsToRelax0++    f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod)+    f (RelaxedDep scope rdm p) = case scope of+      RelaxDepScopeAll        -> Just (p,rdm)+      RelaxDepScopePackage p0+          | p0 == thisPkgName -> Just (p,rdm)+          | otherwise         -> Nothing+      RelaxDepScopePackageId p0+          | p0 == thisPkgId   -> Just (p,rdm)+          | otherwise         -> Nothing++    relaxSome :: Dependency -> Dependency+    relaxSome d@(Dependency depName verRange cs)+        | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =+            -- a '*'-subject acts absorbing, for consistency with+            -- the 'Semigroup RelaxDeps' instance+            Dependency depName (removeBound relKind relMod verRange) cs+        | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =+            Dependency depName (removeBound relKind relMod verRange) cs+        | otherwise = d -- no-op++-- | Internal helper for 'relaxPackageDeps'+removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange+removeBound RelaxLower RelaxDepModNone  = removeLowerBound+removeBound RelaxUpper RelaxDepModNone  = removeUpperBound+removeBound RelaxLower RelaxDepModCaret = transformCaretLower+removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper++-- | Supply defaults for packages without explicit Setup dependencies+--+-- Note: It's important to apply 'addDefaultSetupDepends' after+-- 'addSourcePackages'. Otherwise, the packages inserted by+-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.+--+addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])+                            -> DepResolverParams -> DepResolverParams+addDefaultSetupDependencies defaultSetupDeps params =+    params {+      depResolverSourcePkgIndex =+        fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)+    }+  where+    applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage+    applyDefaultSetupDeps srcpkg =+        srcpkg {+          srcpkgDescription = gpkgdesc {+            PD.packageDescription = pkgdesc {+              PD.setupBuildInfo =+                case PD.setupBuildInfo pkgdesc of+                  Just sbi -> Just sbi+                  Nothing -> case defaultSetupDeps srcpkg of+                    Nothing -> Nothing+                    Just deps | isCustom -> Just PD.SetupBuildInfo {+                                                PD.defaultSetupDepends = True,+                                                PD.setupDepends        = deps+                                            }+                              | otherwise -> Nothing+            }+          }+        }+      where+        isCustom = PD.buildType pkgdesc == PD.Custom+        gpkgdesc = srcpkgDescription srcpkg+        pkgdesc  = PD.packageDescription gpkgdesc++-- | If a package has a custom setup then we need to add a setup-depends+-- on Cabal.+--+addSetupCabalMinVersionConstraint :: Version+                                  -> DepResolverParams -> DepResolverParams+addSetupCabalMinVersionConstraint minVersion =+    addConstraints+      [ LabeledPackageConstraint+          (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)+                             (PackagePropertyVersion $ orLaterVersion minVersion))+          ConstraintSetupCabalMinVersion+      ]+  where+    cabalPkgname = mkPackageName "Cabal"++-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an+-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'.+--+addSetupCabalMaxVersionConstraint :: Version+                                  -> DepResolverParams -> DepResolverParams+addSetupCabalMaxVersionConstraint maxVersion =+    addConstraints+      [ LabeledPackageConstraint+          (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)+                             (PackagePropertyVersion $ earlierVersion maxVersion))+          ConstraintSetupCabalMaxVersion+      ]+  where+    cabalPkgname = mkPackageName "Cabal"+++upgradeDependencies :: DepResolverParams -> DepResolverParams+upgradeDependencies = setPreferenceDefault PreferAllLatest+++reinstallTargets :: DepResolverParams -> DepResolverParams+reinstallTargets params =+    hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params+++-- | A basic solver policy on which all others are built.+--+basicInstallPolicy :: InstalledPackageIndex+                   -> SourcePackageDb+                   -> [PackageSpecifier UnresolvedSourcePackage]+                   -> DepResolverParams+basicInstallPolicy+    installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)+    pkgSpecifiers++  = addPreferences+      [ PackageVersionPreference name ver+      | (name, ver) <- Map.toList sourcePkgPrefs ]++  . addConstraints+      (concatMap pkgSpecifierConstraints pkgSpecifiers)++  . addTargets+      (map pkgSpecifierTarget pkgSpecifiers)++  . hideInstalledPackagesSpecificBySourcePackageId+      [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]++  . addSourcePackages+      [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]++  $ basicDepResolverParams+      installedPkgIndex sourcePkgIndex+++-- | The policy used by all the standard commands, install, fetch, freeze etc+-- (but not the v2-build and related commands).+--+-- It extends the 'basicInstallPolicy' with a policy on setup deps.+--+standardInstallPolicy :: InstalledPackageIndex+                      -> SourcePackageDb+                      -> [PackageSpecifier UnresolvedSourcePackage]+                      -> DepResolverParams+standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++  = addDefaultSetupDependencies mkDefaultSetupDeps++  $ basicInstallPolicy+      installedPkgIndex sourcePkgDb pkgSpecifiers++    where+      -- Force Cabal >= 1.24 dep when the package is affected by #3199.+      mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]+      mkDefaultSetupDeps srcpkg | affected        =+        Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet]+                                | otherwise       = Nothing+        where+          gpkgdesc = srcpkgDescription srcpkg+          pkgdesc  = PD.packageDescription gpkgdesc+          bt       = PD.buildType pkgdesc+          affected = bt == PD.Custom && hasBuildableFalse gpkgdesc++      -- Does this package contain any components with non-empty 'build-depends'+      -- and a 'buildable' field that could potentially be set to 'False'? False+      -- positives are possible.+      hasBuildableFalse :: PD.GenericPackageDescription -> Bool+      hasBuildableFalse gpkg =+        not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))+        where+          buildableConditions      = PD.extractConditions PD.buildable gpkg+          noDepConditions          = PD.extractConditions+                                     (null . PD.targetBuildDepends)    gpkg+          alwaysTrue (PD.Lit True) = True+          alwaysTrue _             = False++-- ------------------------------------------------------------+-- * Interface to the standard resolver+-- ------------------------------------------------------------++chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver+chooseSolver _verbosity preSolver _cinfo =+    case preSolver of+      AlwaysModular -> do+        return Modular++runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc+runSolver Modular = modularResolver++-- | Run the dependency solver.+--+-- Since this is potentially an expensive operation, the result is wrapped in a+-- a 'Progress' structure that can be unfolded to provide progress information,+-- logging messages and the final result or an error.+--+resolveDependencies :: Platform+                    -> CompilerInfo+                    -> PkgConfigDb+                    -> Solver+                    -> DepResolverParams+                    -> Progress String String SolverInstallPlan++    --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages+resolveDependencies platform comp _pkgConfigDB _solver params+  | Set.null (depResolverTargets params)+  = return (validateSolverResult platform comp indGoals [])+  where+    indGoals = depResolverIndependentGoals params++resolveDependencies platform comp pkgConfigDB solver params =++    Step (showDepResolverParams finalparams)+  $ fmap (validateSolverResult platform comp indGoals)+  $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize+                      indGoals noReinstalls+                      shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj+                      solveExes order verbosity (PruneAfterFirstSuccess False))+                     platform comp installedPkgIndex sourcePkgIndex+                     pkgConfigDB preferences constraints targets+  where++    finalparams@(DepResolverParams+      targets constraints+      prefs defpref+      installedPkgIndex+      sourcePkgIndex+      reordGoals+      cntConflicts+      fineGrained+      minimize+      indGoals+      noReinstalls+      shadowing+      strFlags+      allowBootLibs+      onlyConstrained_+      maxBkjumps+      enableBj+      solveExes+      order+      verbosity) =+        if asBool (depResolverAllowBootLibInstalls params)+        then params+        else dontUpgradeNonUpgradeablePackages params++    preferences = interpretPackagesPreference targets defpref prefs+++-- | Give an interpretation to the global 'PackagesPreference' as+--  specific per-package 'PackageVersionPreference'.+--+interpretPackagesPreference :: Set PackageName+                            -> PackagesPreferenceDefault+                            -> [PackagePreference]+                            -> (PackageName -> PackagePreferences)+interpretPackagesPreference selected defaultPref prefs =+  \pkgname -> PackagePreferences (versionPref pkgname)+                                 (installPref pkgname)+                                 (stanzasPref pkgname)+  where+    versionPref pkgname =+      fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)+    versionPrefs = Map.fromListWith (++)+                   [(pkgname, [pref])+                   | PackageVersionPreference pkgname pref <- prefs]++    installPref pkgname =+      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)+    installPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageInstalledPreference pkgname pref <- prefs ]+    installPrefDefault = case defaultPref of+      PreferAllLatest         -> const PreferLatest+      PreferAllInstalled      -> const PreferInstalled+      PreferLatestForSelected -> \pkgname ->+        -- When you say cabal install foo, what you really mean is, prefer the+        -- latest version of foo, but the installed version of everything else+        if pkgname `Set.member` selected then PreferLatest+                                         else PreferInstalled++    stanzasPref pkgname =+      fromMaybe [] (Map.lookup pkgname stanzasPrefs)+    stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))+      [ (pkgname, pref)+      | PackageStanzasPreference pkgname pref <- prefs ]+++-- ------------------------------------------------------------+-- * Checking the result of the solver+-- ------------------------------------------------------------++-- | 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.+--+validateSolverResult :: Platform+                     -> CompilerInfo+                     -> IndependentGoals+                     -> [ResolverPackage UnresolvedPkgLoc]+                     -> SolverInstallPlan+validateSolverResult platform comp indepGoals pkgs =+    case planPackagesProblems platform comp pkgs of+      [] -> case SolverInstallPlan.new indepGoals graph of+              Right plan     -> plan+              Left  problems -> error (formatPlanProblems problems)+      problems               -> error (formatPkgProblems problems)++  where+    graph = Graph.fromDistinctList pkgs++    formatPkgProblems  = formatProblemMessage . map showPlanPackageProblem+    formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem++    formatProblemMessage problems =+      unlines $+        "internal error: could not construct a valid install plan."+      : "The proposed (invalid) plan contained the following problems:"+      : problems+      ++ "Proposed plan:"+      : [SolverInstallPlan.showPlanIndex pkgs]+++data PlanPackageProblem =+       InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc)+                                [PackageProblem]+     | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]++showPlanPackageProblem :: PlanPackageProblem -> String+showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =+     "Package " ++ prettyShow (packageId pkg)+  ++ " has an invalid configuration, in particular:\n"+  ++ unlines [ "  " ++ showPackageProblem problem+             | problem <- packageProblems ]+showPlanPackageProblem (DuplicatePackageSolverId pid dups) =+     "Package " ++ prettyShow (packageId pid) ++ " has "+  ++ show (length dups) ++ " duplicate instances."++planPackagesProblems :: Platform -> CompilerInfo+                     -> [ResolverPackage UnresolvedPkgLoc]+                     -> [PlanPackageProblem]+planPackagesProblems platform cinfo pkgs =+     [ InvalidConfiguredPackage pkg packageProblems+     | Configured pkg <- pkgs+     , let packageProblems = configuredPackageProblems platform cinfo pkg+     , not (null packageProblems) ]+  ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups+     | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]++data PackageProblem = DuplicateFlag PD.FlagName+                    | MissingFlag   PD.FlagName+                    | ExtraFlag     PD.FlagName+                    | DuplicateDeps [PackageId]+                    | MissingDep    Dependency+                    | ExtraDep      PackageId+                    | InvalidDep    Dependency PackageId++showPackageProblem :: PackageProblem -> String+showPackageProblem (DuplicateFlag flag) =+  "duplicate flag in the flag assignment: " ++ PD.unFlagName flag++showPackageProblem (MissingFlag flag) =+  "missing an assignment for the flag: " ++ PD.unFlagName flag++showPackageProblem (ExtraFlag flag) =+  "extra flag given that is not used by the package: " ++ PD.unFlagName flag++showPackageProblem (DuplicateDeps pkgids) =+     "duplicate packages specified as selected dependencies: "+  ++ intercalate ", " (map prettyShow pkgids)++showPackageProblem (MissingDep dep) =+     "the package has a dependency " ++ prettyShow dep+  ++ " but no package has been selected to satisfy it."++showPackageProblem (ExtraDep pkgid) =+     "the package configuration specifies " ++ prettyShow pkgid+  ++ " but (with the given flag assignment) the package does not actually"+  ++ " depend on any version of that package."++showPackageProblem (InvalidDep dep pkgid) =+     "the package depends on " ++ prettyShow dep+  ++ " but the configuration specifies " ++ prettyShow pkgid+  ++ " which does not satisfy the dependency."++-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if+-- in the configuration given by the flag assignment, all the package+-- dependencies are satisfied by the specified packages.+--+configuredPackageProblems :: Platform -> CompilerInfo+                          -> SolverPackage UnresolvedPkgLoc -> [PackageProblem]+configuredPackageProblems platform cinfo+  (SolverPackage pkg specifiedFlags stanzas specifiedDeps0  _specifiedExeDeps') =+     [ DuplicateFlag flag+     | flag <- PD.findDuplicateFlagAssignments specifiedFlags ]+  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]+  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]+  ++ [ DuplicateDeps pkgs+     | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))+                                specifiedDeps1) ]+  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]+  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]+  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps+                            , not (packageSatisfiesDependency pkgid dep) ]+  -- TODO: sanity tests on executable deps+  where+    thisPkgName = packageName (srcpkgDescription pkg)++    specifiedDeps1 :: ComponentDeps [PackageId]+    specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0++    specifiedDeps :: [PackageId]+    specifiedDeps = CD.flatDeps specifiedDeps1++    mergedFlags = mergeBy compare+      (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))+      (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO++    packageSatisfiesDependency+      (PackageIdentifier name  version)+      (Dependency        name' versionRange _) = assert (name == name') $+        version `withinRange` versionRange++    dependencyName (Dependency name _ _) = name++    mergedDeps :: [MergeResult Dependency PackageId]+    mergedDeps = mergeDeps requiredDeps specifiedDeps++    mergeDeps :: [Dependency] -> [PackageId]+              -> [MergeResult Dependency PackageId]+    mergeDeps required specified =+      let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in+      mergeBy+        (\dep pkgid -> dependencyName dep `compare` packageName pkgid)+        (sortNubOn dependencyName required)+        (sortNubOn packageName    specified)++    compSpec = enableStanzas stanzas+    -- TODO: It would be nicer to use ComponentDeps here so we can be more+    -- precise in our checks. In fact, this no longer relies on buildDepends and+    -- thus should be easier to fix. As long as we _do_ use a flat list here, we+    -- have to allow for duplicates when we fold specifiedDeps; once we have+    -- proper ComponentDeps here we should get rid of the `nubOn` in+    -- `mergeDeps`.+    requiredDeps :: [Dependency]+    requiredDeps =+      --TODO: use something lower level than finalizePD+      case finalizePD specifiedFlags+         compSpec+         (const True)+         platform cinfo+         []+         (srcpkgDescription pkg) of+        Right (resolvedPkg, _) ->+            -- we filter self/internal dependencies. They are still there.+            -- This is INCORRECT.+            --+            -- If we had per-component solver, it would make this unnecessary,+            -- but no finalizePDs picks components we are not building, eg. exes.+            -- See #3775+            --+            filter ((/= thisPkgName) . dependencyName)+                (PD.enabledBuildDepends resolvedPkg compSpec)+          ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)+        Left  _ ->+          error "configuredPackageInvalidDeps internal error"+++-- ------------------------------------------------------------+-- * Simple resolver that ignores dependencies+-- ------------------------------------------------------------++-- | A simplistic method of resolving a list of target package names to+-- available packages.+--+-- Specifically, it does not consider package dependencies at all. Unlike+-- 'resolveDependencies', no attempt is made to ensure that the selected+-- packages have dependencies that are satisfiable or consistent with+-- each other.+--+-- 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'.+-- It simply means preferences for installed packages will be ignored.+--+resolveWithoutDependencies :: DepResolverParams+                           -> Either [ResolveNoDepsError] [UnresolvedSourcePackage]+resolveWithoutDependencies (DepResolverParams targets constraints+                              prefs defpref installedPkgIndex sourcePkgIndex+                              _reorderGoals _countConflicts _fineGrained+                              _minimizeConflictSet _indGoals _avoidReinstalls+                              _shadowing _strFlags _maxBjumps _enableBj _solveExes+                              _allowBootLibInstalls _onlyConstrained _order _verbosity) =+    collectEithers $ map selectPackage (Set.toList targets)+  where+    selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage+    selectPackage pkgname+      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions+      | otherwise    = Right $! maximumBy bestByPrefs choices++      where+        -- Constraints+        requiredVersions = packageConstraints pkgname+        choices          = PackageIndex.lookupDependency sourcePkgIndex+                                                         pkgname+                                                         requiredVersions++        -- Preferences+        PackagePreferences preferredVersions preferInstalled _+          = packagePreferences pkgname++        bestByPrefs   = comparing $ \pkg ->+                          (installPref pkg, versionPref pkg, packageVersion pkg)+        installPref   = case preferInstalled of+          PreferLatest    -> const False+          PreferInstalled -> not . null+                           . InstalledPackageIndex.lookupSourcePackageId+                                                     installedPkgIndex+                           . packageId+        versionPref pkg = length . filter (packageVersion pkg `withinRange`) $+                          preferredVersions++    packageConstraints :: PackageName -> VersionRange+    packageConstraints pkgname =+      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap+    packageVersionConstraintMap =+      let pcs = map unlabelPackageConstraint constraints+      in Map.fromList [ (scopeToPackageName scope, range)+                      | PackageConstraint+                          scope (PackagePropertyVersion range) <- pcs ]++    packagePreferences :: PackageName -> PackagePreferences+    packagePreferences = interpretPackagesPreference targets defpref prefs+++collectEithers :: [Either a b] -> Either [a] [b]+collectEithers = collect . partitionEithers+  where+    collect ([], xs) = Right xs+    collect (errs,_) = Left errs++-- | Errors for 'resolveWithoutDependencies'.+--+data ResolveNoDepsError =++     -- | A package name which cannot be resolved to a specific package.+     -- Also gives the constraint on the version and whether there was+     -- a constraint on the package being installed.+     ResolveUnsatisfiable PackageName VersionRange++instance Show ResolveNoDepsError where+  show (ResolveUnsatisfiable name ver) =+       "There is no available version of " ++ prettyShow name+    ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver)
+ src/Distribution/Client/Dependency/Types.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Dependency.Types (+    PreSolver(..),+    Solver(..),+    PackagesPreferenceDefault(..),+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Text.PrettyPrint (text)++import qualified Distribution.Compat.CharParsing as P+++-- | All the solvers that can be selected.+data PreSolver = AlwaysModular+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++-- | All the solvers that can be used.+data Solver = Modular+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance Binary PreSolver+instance Binary Solver++instance Structured PreSolver+instance Structured Solver++instance Pretty PreSolver where+    pretty AlwaysModular = text "modular"++instance Parsec PreSolver where+    parsec = do+        name <- P.munch1 isAlpha+        case map toLower name of+            "modular" -> return AlwaysModular+            _         -> P.unexpected $ "PreSolver: " ++ name++-- | Global policy for all packages to say if we prefer package versions that+-- are already installed locally or if we just prefer the latest available.+--+data PackagesPreferenceDefault =++     -- | Always prefer the latest version irrespective of any existing+     -- installed version.+     --+     -- * This is the standard policy for upgrade.+     --+     PreferAllLatest++     -- | Always prefer the installed versions over ones that would need to be+     -- installed. Secondarily, prefer latest versions (eg the latest installed+     -- version or if there are none then the latest source version).+   | PreferAllInstalled++     -- | Prefer the latest version for packages that are explicitly requested+     -- but prefers the installed version for any other packages.+     --+     -- * This is the standard policy for install.+     --+   | PreferLatestForSelected+  deriving Show
+ src/Distribution/Client/DistDirLayout.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE RecordWildCards #-}++-- |+--+-- The layout of the .\/dist\/ directory where cabal keeps all of its state+-- and build artifacts.+--+module Distribution.Client.DistDirLayout (+    -- * 'DistDirLayout'+    DistDirLayout(..),+    DistDirParams(..),+    defaultDistDirLayout,+    ProjectRoot(..),++    -- * 'StoreDirLayout'+    StoreDirLayout(..),+    defaultStoreDirLayout,++    -- * 'CabalDirLayout'+    CabalDirLayout(..),+    mkCabalDirLayout,+    defaultCabalDirLayout+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import System.FilePath++import Distribution.Package+         ( PackageId, ComponentId, UnitId )+import Distribution.Compiler+import Distribution.Simple.Compiler+         ( PackageDB(..), PackageDBStack, OptimisationLevel(..) )+import Distribution.Types.ComponentName+import Distribution.Types.LibraryName+import Distribution.System+++-- | Information which can be used to construct the path to+-- the build directory of a build.  This is LESS fine-grained+-- than what goes into the hashed 'InstalledPackageId',+-- and for good reason: we don't want this path to change if+-- the user, say, adds a dependency to their project.+data DistDirParams = DistDirParams {+    distParamUnitId         :: UnitId,+    distParamPackageId      :: PackageId,+    distParamComponentId    :: ComponentId,+    distParamComponentName  :: Maybe ComponentName,+    distParamCompilerId     :: CompilerId,+    distParamPlatform       :: Platform,+    distParamOptimization   :: OptimisationLevel+    -- TODO (see #3343):+    --  Flag assignments+    --  Optimization+    }+++-- | The layout of the project state directory. Traditionally this has been+-- called the @dist@ directory.+--+data DistDirLayout = DistDirLayout {++       -- | The root directory of the project. Many other files are relative to+       -- this location. In particular, the @cabal.project@ lives here.+       --+       distProjectRootDirectory     :: FilePath,++       -- | The @cabal.project@ file and related like @cabal.project.freeze@.+       -- The parameter is for the extension, like \"freeze\", or \"\" for the+       -- main file.+       --+       distProjectFile              :: String -> FilePath,++       -- | The \"dist\" directory, which is the root of where cabal keeps all+       -- its state including the build artifacts from each package we build.+       --+       distDirectory                :: FilePath,++       -- | The directory under dist where we keep the build artifacts for a+       -- package we're building from a local directory.+       --+       -- This uses a 'UnitId' not just a 'PackageName' because technically+       -- we can have multiple instances of the same package in a solution+       -- (e.g. setup deps).+       --+       distBuildDirectory           :: DistDirParams -> FilePath,+       distBuildRootDirectory       :: FilePath,++       -- | The directory under dist where we download tarballs and source+       -- control repos to.+       --+       distDownloadSrcDirectory     :: FilePath,++       -- | The directory under dist where we put the unpacked sources of+       -- packages, in those cases where it makes sense to keep the build+       -- artifacts to reduce rebuild times.+       --+       distUnpackedSrcDirectory     :: PackageId -> FilePath,+       distUnpackedSrcRootDirectory :: FilePath,++       -- | The location for project-wide cache files (e.g. state used in+       -- incremental rebuilds).+       --+       distProjectCacheFile         :: String -> FilePath,+       distProjectCacheDirectory    :: FilePath,++       -- | The location for package-specific cache files (e.g. state used in+       -- incremental rebuilds).+       --+       distPackageCacheFile         :: DistDirParams -> String -> FilePath,+       distPackageCacheDirectory    :: DistDirParams -> FilePath,++       -- | The location that sdists are placed by default.+       distSdistFile                :: PackageId -> FilePath,+       distSdistDirectory           :: FilePath,++       distTempDirectory            :: FilePath,+       distBinDirectory             :: FilePath,++       distPackageDB                :: CompilerId -> PackageDB+     }+++-- | The layout of a cabal nix-style store.+--+data StoreDirLayout = StoreDirLayout {+       storeDirectory         :: CompilerId -> FilePath,+       storePackageDirectory  :: CompilerId -> UnitId -> FilePath,+       storePackageDBPath     :: CompilerId -> FilePath,+       storePackageDB         :: CompilerId -> PackageDB,+       storePackageDBStack    :: CompilerId -> PackageDBStack,+       storeIncomingDirectory :: CompilerId -> FilePath,+       storeIncomingLock      :: CompilerId -> UnitId -> FilePath+     }+++--TODO: move to another module, e.g. CabalDirLayout?+-- or perhaps rename this module to DirLayouts.++-- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir+-- on unix, and equivalents on other systems.+--+-- At the moment this is just a partial specification, but the idea is+-- eventually to cover it all.+--+data CabalDirLayout = CabalDirLayout {+       cabalStoreDirLayout        :: StoreDirLayout,++       cabalLogsDirectory         :: FilePath,+       cabalWorldFile             :: FilePath+     }+++-- | Information about the root directory of the project.+--+-- It can either be an implicit project root in the current dir if no+-- @cabal.project@ file is found, or an explicit root if the file is found.+--+data ProjectRoot =+       -- | -- ^ An implicit project root. It contains the absolute project+       -- root dir.+       ProjectRootImplicit FilePath++       -- | -- ^ An explicit project root. It contains the absolute project+       -- root dir and the relative @cabal.project@ file (or explicit override)+     | ProjectRootExplicit FilePath FilePath+  deriving (Eq, Show)++-- | Make the default 'DistDirLayout' based on the project root dir and+-- optional overrides for the location of the @dist@ directory and the+-- @cabal.project@ file.+--+defaultDistDirLayout :: ProjectRoot    -- ^ the project root+                     -> Maybe FilePath -- ^ the @dist@ directory or default+                                       -- (absolute or relative to the root)+                     -> DistDirLayout+defaultDistDirLayout projectRoot mdistDirectory =+    DistDirLayout {..}+  where+    (projectRootDir, projectFile) = case projectRoot of+      ProjectRootImplicit dir      -> (dir, dir </> "cabal.project")+      ProjectRootExplicit dir file -> (dir, dir </> file)++    distProjectRootDirectory = projectRootDir+    distProjectFile ext      = projectFile <.> ext++    distDirectory = distProjectRootDirectory+                </> fromMaybe "dist-newstyle" mdistDirectory+    --TODO: switch to just dist at some point, or some other new name++    distBuildRootDirectory   = distDirectory </> "build"+    distBuildDirectory params =+        distBuildRootDirectory </>+        prettyShow (distParamPlatform params) </>+        prettyShow (distParamCompilerId params) </>+        prettyShow (distParamPackageId params) </>+        (case distParamComponentName params of+            Nothing                  -> ""+            Just (CLibName LMainLibName) -> ""+            Just (CLibName (LSubLibName name)) -> "l" </> prettyShow name+            Just (CFLibName name)    -> "f" </> prettyShow name+            Just (CExeName name)     -> "x" </> prettyShow name+            Just (CTestName name)    -> "t" </> prettyShow name+            Just (CBenchName name)   -> "b" </> prettyShow name) </>+        (case distParamOptimization params of+            NoOptimisation -> "noopt"+            NormalOptimisation -> ""+            MaximumOptimisation -> "opt") </>+        (let uid_str = prettyShow (distParamUnitId params)+         in if uid_str == prettyShow (distParamComponentId params)+                then ""+                else uid_str)++    distUnpackedSrcRootDirectory   = distDirectory </> "src"+    distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory+                                      </> prettyShow pkgid+    -- we shouldn't get name clashes so this should be fine:+    distDownloadSrcDirectory       = distUnpackedSrcRootDirectory++    distProjectCacheDirectory = distDirectory </> "cache"+    distProjectCacheFile name = distProjectCacheDirectory </> name++    distPackageCacheDirectory params = distBuildDirectory params </> "cache"+    distPackageCacheFile params name = distPackageCacheDirectory params </> name++    distSdistFile pid = distSdistDirectory </> prettyShow pid <.> "tar.gz"++    distSdistDirectory = distDirectory </> "sdist"++    distTempDirectory = distDirectory </> "tmp"++    distBinDirectory = distDirectory </> "bin"++    distPackageDBPath compid = distDirectory </> "packagedb" </> prettyShow compid+    distPackageDB = SpecificPackageDB . distPackageDBPath+++defaultStoreDirLayout :: FilePath -> StoreDirLayout+defaultStoreDirLayout storeRoot =+    StoreDirLayout {..}+  where+    storeDirectory compid =+      storeRoot </> prettyShow compid++    storePackageDirectory compid ipkgid =+      storeDirectory compid </> prettyShow ipkgid++    storePackageDBPath compid =+      storeDirectory compid </> "package.db"++    storePackageDB compid =+      SpecificPackageDB (storePackageDBPath compid)++    storePackageDBStack compid =+      [GlobalPackageDB, storePackageDB compid]++    storeIncomingDirectory compid =+      storeDirectory compid </> "incoming"++    storeIncomingLock compid unitid =+      storeIncomingDirectory compid </> prettyShow unitid <.> "lock"+++defaultCabalDirLayout :: FilePath -> CabalDirLayout+defaultCabalDirLayout cabalDir =+    mkCabalDirLayout cabalDir Nothing Nothing++mkCabalDirLayout :: FilePath -- ^ Cabal directory+                 -> Maybe FilePath -- ^ Store directory. Must be absolute+                 -> Maybe FilePath -- ^ Log directory+                 -> CabalDirLayout+mkCabalDirLayout cabalDir mstoreDir mlogDir =+    CabalDirLayout {..}+  where+    cabalStoreDirLayout =+        defaultStoreDirLayout (fromMaybe (cabalDir </> "store") mstoreDir)+    cabalLogsDirectory = fromMaybe (cabalDir </> "logs") mlogDir+    cabalWorldFile = cabalDir </> "world"
+ src/Distribution/Client/Fetch.hs view
@@ -0,0 +1,232 @@+------------------------------------------------------------------------------- |+-- Module      :  Distribution.Client.Fetch+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal fetch command+-----------------------------------------------------------------------------+module Distribution.Client.Fetch (+    fetch,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.FetchUtils hiding (fetchPackage)+import Distribution.Client.Dependency+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import Distribution.Client.Setup+         ( GlobalFlags(..), FetchFlags(..), RepoContext(..) )++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb )+import Distribution.Solver.Types.SolverPackage+import Distribution.Solver.Types.SourcePackage++import Distribution.Package+         ( packageId )+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo, PackageDBStack )+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.Simple.Program+         ( ProgramDb )+import Distribution.Simple.Setup+         ( fromFlag, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( die', notice, debug )+import Distribution.System+         ( Platform )++-- ------------------------------------------------------------+-- * The fetch command+-- ------------------------------------------------------------++--TODO:+-- * add fetch -o support+-- * support tarball URLs via ad-hoc download cache (or in -o mode?)+-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied+-- * Port various flags from install:+--   * --updage-dependencies+--   * --constraint and --preference+--   * --only-dependencies, but note it conflicts with --no-deps+++-- | Fetch a list of packages and their dependencies.+--+fetch :: Verbosity+      -> PackageDBStack+      -> RepoContext+      -> Compiler+      -> Platform+      -> ProgramDb+      -> GlobalFlags+      -> FetchFlags+      -> [UserTarget]+      -> IO ()+fetch verbosity _ _ _ _ _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++fetch verbosity packageDBs repoCtxt comp platform progdb+      globalFlags fetchFlags userTargets = do++    traverse_ (checkTarget verbosity) userTargets++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb++    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       userTargets++    pkgs  <- planPackages+               verbosity comp platform fetchFlags+               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers++    pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs+    if null pkgs'+      --TODO: when we add support for remote tarballs then this message+      -- will need to be changed because for remote tarballs we fetch them+      -- at the earlier phase.+      then notice verbosity $ "No packages need to be fetched. "+                           ++ "All the requested packages are already local "+                           ++ "or cached locally."+      else if dryRun+             then notice verbosity $ unlines $+                     "The following packages would be fetched:"+                   : map (prettyShow . packageId) pkgs'++             else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs'++  where+    dryRun = fromFlag (fetchDryRun fetchFlags)++planPackages :: Verbosity+             -> Compiler+             -> Platform+             -> FetchFlags+             -> InstalledPackageIndex+             -> SourcePackageDb+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> IO [UnresolvedSourcePackage]+planPackages verbosity comp platform fetchFlags+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers++  | includeDependencies = do+      solver <- chooseSolver verbosity+                (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp)+      notice verbosity "Resolving dependencies..."+      installPlan <- foldProgress logMsg (die' verbosity) return $+                       resolveDependencies+                         platform (compilerInfo comp) pkgConfigDb+                         solver+                         resolverParams++      -- The packages we want to fetch are those packages the 'InstallPlan'+      -- that are in the 'InstallPlan.Configured' state.+      return+        [ solverPkgSource cpkg+        | (SolverInstallPlan.Configured cpkg)+            <- SolverInstallPlan.toList installPlan ]++  | otherwise =+      either (die' verbosity . unlines . map show) return $+        resolveWithoutDependencies resolverParams++  where+    resolverParams =++        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setCountConflicts countConflicts++      . setFineGrainedConflicts fineGrainedConflicts++      . setMinimizeConflictSet minimizeConflictSet++      . setShadowPkgs shadowPkgs++      . setStrongFlags strongFlags++      . setAllowBootLibInstalls allowBootLibInstalls++      . setOnlyConstrained onlyConstrained++      . setSolverVerbosity verbosity++      . addConstraints+          [ let pc = PackageConstraint+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)+                     (PackagePropertyStanzas stanzas)+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+          | pkgSpecifier <- pkgSpecifiers ]++        -- Reinstall the targets given on the command line so that the dep+        -- resolver will decide that they need fetching, even if they're+        -- already installed. Since we want to get the source packages of+        -- things we might have installed (but not have the sources for).+      . reinstallTargets++      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++    includeDependencies = fromFlag (fetchDeps fetchFlags)+    logMsg message rest = debug verbosity message >> rest++    stanzas           = [ TestStanzas | testsEnabled ]+                     ++ [ BenchStanzas | benchmarksEnabled ]+    testsEnabled      = fromFlagOrDefault False $ fetchTests fetchFlags+    benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags++    reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)+    countConflicts   = fromFlag (fetchCountConflicts   fetchFlags)+    fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags)+    minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags)+    independentGoals = fromFlag (fetchIndependentGoals fetchFlags)+    shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)+    strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)+    maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)+    allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags)+    onlyConstrained  = fromFlag (fetchOnlyConstrained  fetchFlags)+++checkTarget :: Verbosity -> UserTarget -> IO ()+checkTarget verbosity target = case target of+    UserTargetRemoteTarball _uri+      -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "+            ++ "In the meantime you can use the 'unpack' commands."+    _ -> return ()++fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()+fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of+    LocalUnpackedPackage _dir  -> return ()+    LocalTarballPackage  _file -> return ()++    RemoteTarballPackage _uri _ ->+      die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "+         ++ "In the meantime you can use the 'unpack' commands."++    RemoteSourceRepoPackage _repo _ ->+      die' verbosity $ "The 'fetch' command does not yet support remote "+         ++ "source repositores."++    RepoTarballPackage repo pkgid _ -> do+      _ <- fetchRepoTarball verbosity repoCtxt repo pkgid+      return ()
+ src/Distribution/Client/FetchUtils.hs view
@@ -0,0 +1,317 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.FetchUtils+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for fetching packages+-----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}+module Distribution.Client.FetchUtils (++    -- * fetching packages+    fetchPackage,+    isFetched,+    checkFetched,++    -- ** specifically for repo packages+    checkRepoTarballFetched,+    fetchRepoTarball,++    -- ** fetching packages asynchronously+    asyncFetchPackages,+    waitAsyncFetchPackage,+    AsyncFetchMap,++    -- * fetching other things+    downloadIndex,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Types+import Distribution.Client.HttpUtils+         ( downloadURI, isOldHackageURI, DownloadResult(..)+         , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )++import Distribution.Package+         ( PackageId, packageName, packageVersion )+import Distribution.Simple.Utils+         ( notice, info, debug, die' )+import Distribution.Verbosity+         ( verboseUnmarkOutput )+import Distribution.Client.GlobalFlags+         ( RepoContext(..) )+import Distribution.Client.Utils+         ( ProgressPhase(..), progressMessage )++import qualified Data.Map as Map+import Control.Exception+import Control.Concurrent.Async+import Control.Concurrent.MVar+import System.Directory+         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )+import System.IO+         ( openTempFile, hClose )+import System.FilePath+         ( (</>), (<.>) )+import qualified System.FilePath.Posix as FilePath.Posix+         ( combine, joinPath )+import Network.URI+         ( URI(uriPath) )++import qualified Hackage.Security.Client as Sec++-- ------------------------------------------------------------+-- * Actually fetch things+-- ------------------------------------------------------------++-- | Returns @True@ if the package has already been fetched+-- or does not need fetching.+--+isFetched :: UnresolvedPkgLoc -> IO Bool+isFetched loc = case loc of+    LocalUnpackedPackage _dir       -> return True+    LocalTarballPackage  _file      -> return True+    RemoteTarballPackage _uri local -> return (isJust local)+    RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)+    RemoteSourceRepoPackage _ local -> return (isJust local)+++-- | Checks if the package has already been fetched (or does not need+-- fetching) and if so returns evidence in the form of a 'PackageLocation'+-- with a resolved local file location.+--+checkFetched :: UnresolvedPkgLoc+             -> IO (Maybe ResolvedPkgLoc)+checkFetched loc = case loc of+    LocalUnpackedPackage dir  ->+      return (Just $ LocalUnpackedPackage dir)+    LocalTarballPackage  file ->+      return (Just $ LocalTarballPackage  file)+    RemoteTarballPackage uri (Just file) ->+      return (Just $ RemoteTarballPackage uri file)+    RepoTarballPackage repo pkgid (Just file) ->+      return (Just $ RepoTarballPackage repo pkgid file)+    RemoteSourceRepoPackage repo (Just file) ->+      return (Just $ RemoteSourceRepoPackage repo file)++    RemoteTarballPackage     _uri Nothing -> return Nothing+    RemoteSourceRepoPackage _repo Nothing -> return Nothing+    RepoTarballPackage repo pkgid Nothing ->+      fmap (fmap (RepoTarballPackage repo pkgid))+           (checkRepoTarballFetched repo pkgid)++-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.+--+checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)+checkRepoTarballFetched repo pkgid = do+    let file = packageFile repo pkgid+    exists <- doesFileExist file+    if exists+      then return (Just file)+      else return Nothing+++-- | Fetch a package if we don't have it already.+--+fetchPackage :: Verbosity+             -> RepoContext+             -> UnresolvedPkgLoc+             -> IO ResolvedPkgLoc+fetchPackage verbosity repoCtxt loc = case loc of+    LocalUnpackedPackage dir  ->+      return (LocalUnpackedPackage dir)+    LocalTarballPackage  file ->+      return (LocalTarballPackage  file)+    RemoteTarballPackage uri (Just file) ->+      return (RemoteTarballPackage uri file)+    RepoTarballPackage repo pkgid (Just file) ->+      return (RepoTarballPackage repo pkgid file)+    RemoteSourceRepoPackage repo (Just dir) ->+      return (RemoteSourceRepoPackage repo dir)++    RemoteTarballPackage uri Nothing -> do+      path <- downloadTarballPackage uri+      return (RemoteTarballPackage uri path)+    RepoTarballPackage repo pkgid Nothing -> do+      local <- fetchRepoTarball verbosity repoCtxt repo pkgid+      return (RepoTarballPackage repo pkgid local)+    RemoteSourceRepoPackage _repo Nothing ->+      die' verbosity "fetchPackage: source repos not supported"+  where+    downloadTarballPackage uri = do+      transport <- repoContextGetTransport repoCtxt+      transportCheckHttps verbosity transport uri+      notice verbosity ("Downloading " ++ show uri)+      tmpdir <- getTemporaryDirectory+      (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"+      hClose hnd+      _ <- downloadURI transport verbosity uri path+      return path+++-- | Fetch a repo package if we don't have it already.+--+fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath+fetchRepoTarball verbosity' repoCtxt repo pkgid = do+  fetched <- doesFileExist (packageFile repo pkgid)+  if fetched+    then do info verbosity $ prettyShow pkgid ++ " has already been downloaded."+            return (packageFile repo pkgid)+    else do progressMessage verbosity ProgressDownloading (prettyShow pkgid)+            res <- downloadRepoPackage+            progressMessage verbosity ProgressDownloaded (prettyShow pkgid)+            return res+  where+    -- whether we download or not is non-deterministic+    verbosity = verboseUnmarkOutput verbosity'++    downloadRepoPackage = case repo of+      RepoLocalNoIndex{} -> return (packageFile repo pkgid)++      RepoRemote{..} -> do+        transport <- repoContextGetTransport repoCtxt+        remoteRepoCheckHttps verbosity transport repoRemote+        let uri  = packageURI  repoRemote pkgid+            dir  = packageDir  repo       pkgid+            path = packageFile repo       pkgid+        createDirectoryIfMissing True dir+        _ <- downloadURI transport verbosity uri path+        return path++      RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do+        let dir  = packageDir  repo pkgid+            path = packageFile repo pkgid+        createDirectoryIfMissing True dir+        Sec.uncheckClientErrors $ do+          info verbosity ("Writing " ++ path)+          Sec.downloadPackage' rep pkgid path+        return path++-- | Downloads an index file to [config-dir/packages/serv-id] without+-- hackage-security. You probably don't want to call this directly;+-- use 'updateRepo' instead.+--+downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult+downloadIndex transport verbosity remoteRepo cacheDir = do+  remoteRepoCheckHttps verbosity transport remoteRepo+  let uri = (remoteRepoURI remoteRepo) {+              uriPath = uriPath (remoteRepoURI remoteRepo)+                          `FilePath.Posix.combine` "00-index.tar.gz"+            }+      path = cacheDir </> "00-index" <.> "tar.gz"+  createDirectoryIfMissing True cacheDir+  downloadURI transport verbosity uri path+++-- ------------------------------------------------------------+-- * Async fetch wrapper utilities+-- ------------------------------------------------------------++type AsyncFetchMap = Map UnresolvedPkgLoc+                         (MVar (Either SomeException ResolvedPkgLoc))++-- | Fork off an async action to download the given packages (by location).+--+-- The downloads are initiated in order, so you can arrange for packages that+-- will likely be needed sooner to be earlier in the list.+--+-- The body action is passed a map from those packages (identified by their+-- location) to a completion var for that package. So the body action should+-- lookup the location and use 'asyncFetchPackage' to get the result.+--+asyncFetchPackages :: Verbosity+                   -> RepoContext+                   -> [UnresolvedPkgLoc]+                   -> (AsyncFetchMap -> IO a)+                   -> IO a+asyncFetchPackages verbosity repoCtxt pkglocs body = do+    --TODO: [nice to have] use parallel downloads?++    asyncDownloadVars <- sequenceA+        [ do v <- newEmptyMVar+             return (pkgloc, v)+        | pkgloc <- pkglocs+        ]++    let fetchPackages :: IO ()+        fetchPackages =+          for_ asyncDownloadVars $ \(pkgloc, var) -> do+            -- Suppress marking here, because 'withAsync' means+            -- that we get nondeterministic interleaving+            result <- try $ fetchPackage (verboseUnmarkOutput verbosity)+                                repoCtxt pkgloc+            putMVar var result++    withAsync fetchPackages $ \_ ->+      body (Map.fromList asyncDownloadVars)+++-- | Expect to find a download in progress in the given 'AsyncFetchMap'+-- and wait on it to finish.+--+-- If the download failed with an exception then this will be thrown.+--+-- Note: This function is supposed to be idempotent, as our install plans+-- can now use the same tarball for many builds, e.g. different+-- components and/or qualified goals, and these all go through the+-- download phase so we end up using 'waitAsyncFetchPackage' twice on+-- the same package. C.f. #4461.+waitAsyncFetchPackage :: Verbosity+                      -> AsyncFetchMap+                      -> UnresolvedPkgLoc+                      -> IO ResolvedPkgLoc+waitAsyncFetchPackage verbosity downloadMap srcloc =+    case Map.lookup srcloc downloadMap of+      Just hnd -> do+        debug verbosity $ "Waiting for download of " ++ show srcloc+        either throwIO return =<< readMVar hnd+      Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"+++-- ------------------------------------------------------------+-- * Path utilities+-- ------------------------------------------------------------++-- | Generate the full path to the locally cached copy of+-- the tarball for a given @PackageIdentifer@.+--+packageFile :: Repo -> PackageId -> FilePath+packageFile repo pkgid = packageDir repo pkgid+                     </> prettyShow pkgid+                     <.> "tar.gz"++-- | Generate the full path to the directory where the local cached copy of+-- the tarball for a given @PackageIdentifer@ is stored.+--+packageDir :: Repo -> PackageId -> FilePath+packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir+packageDir repo pkgid = repoLocalDir repo+                    </> prettyShow (packageName    pkgid)+                    </> prettyShow (packageVersion pkgid)++-- | Generate the URI of the tarball for a given package.+--+packageURI :: RemoteRepo -> PackageId -> URI+packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,prettyShow (packageName    pkgid)+      ,prettyShow (packageVersion pkgid)+      ,prettyShow pkgid <.> "tar.gz"]+  }+packageURI repo pkgid =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,"package"+      ,prettyShow pkgid <.> "tar.gz"]+  }
+ src/Distribution/Client/FileMonitor.hs view
@@ -0,0 +1,1162 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,+             NamedFieldPuns, BangPatterns, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | An abstraction to help with re-running actions when files or other+-- input values they depend on have changed.+--+module Distribution.Client.FileMonitor (++  -- * Declaring files to monitor+  MonitorFilePath(..),+  MonitorKindFile(..),+  MonitorKindDir(..),+  FilePathGlob(..),+  monitorFile,+  monitorFileHashed,+  monitorNonExistentFile,+  monitorFileExistence,+  monitorDirectory,+  monitorNonExistentDirectory,+  monitorDirectoryExistence,+  monitorFileOrDirectory,+  monitorFileGlob,+  monitorFileGlobExistence,+  monitorFileSearchPath,+  monitorFileHashedSearchPath,++  -- * Creating and checking sets of monitored files+  FileMonitor(..),+  newFileMonitor,+  MonitorChanged(..),+  MonitorChangedReason(..),+  checkFileMonitorChanged,+  updateFileMonitor,+  MonitorTimestamp,+  beginUpdateFileMonitor,++  -- * Internal+  MonitorStateFileSet,+  MonitorStateFile,+  MonitorStateGlob,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+import qualified Distribution.Compat.Binary as Binary++import qualified Data.Map.Strict as Map+import Data.Binary.Get (runGetOrFail)+import qualified Data.ByteString.Lazy as BS+import qualified Data.Hashable as Hashable++import           Control.Monad+import           Control.Monad.Trans (MonadIO, liftIO)+import           Control.Monad.State (StateT, mapStateT)+import qualified Control.Monad.State as State+import           Control.Monad.Except (ExceptT, runExceptT, withExceptT,+                                       throwError)+import           Control.Exception++import           Distribution.Compat.Time+import           Distribution.Client.Glob+import           Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)+import           Distribution.Client.Utils (mergeBy, MergeResult(..))+import           Distribution.Utils.Structured (structuredEncode, Tag (..))+import           System.FilePath+import           System.Directory+import           System.IO++------------------------------------------------------------------------------+-- Types for specifying files to monitor+--+++-- | A description of a file (or set of files) to monitor for changes.+--+-- Where file paths are relative they are relative to a common directory+-- (e.g. project root), not necessarily the process current directory.+--+data MonitorFilePath =+     MonitorFile {+       monitorKindFile :: !MonitorKindFile,+       monitorKindDir  :: !MonitorKindDir,+       monitorPath     :: !FilePath+     }+   | MonitorFileGlob {+       monitorKindFile :: !MonitorKindFile,+       monitorKindDir  :: !MonitorKindDir,+       monitorPathGlob :: !FilePathGlob+     }+  deriving (Eq, Show, Generic)++data MonitorKindFile = FileExists+                     | FileModTime+                     | FileHashed+                     | FileNotExists+  deriving (Eq, Show, Generic)++data MonitorKindDir  = DirExists+                     | DirModTime+                     | DirNotExists+  deriving (Eq, Show, Generic)++instance Binary MonitorFilePath+instance Binary MonitorKindFile+instance Binary MonitorKindDir++instance Structured MonitorFilePath+instance Structured MonitorKindFile+instance Structured MonitorKindDir++-- | Monitor a single file for changes, based on its modification time.+-- The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+--+monitorFile :: FilePath -> MonitorFilePath+monitorFile = MonitorFile FileModTime DirNotExists++-- | Monitor a single file for changes, based on its modification time+-- and content hash. The monitored file is considered to have changed if+-- it no longer exists or if its modification time and content hash have+-- changed.+--+monitorFileHashed :: FilePath -> MonitorFilePath+monitorFileHashed = MonitorFile FileHashed DirNotExists++-- | Monitor a single non-existent file for changes. The monitored file+-- is considered to have changed if it exists.+--+monitorNonExistentFile :: FilePath -> MonitorFilePath+monitorNonExistentFile = MonitorFile FileNotExists DirNotExists++-- | Monitor a single file for existence only. The monitored file is+-- considered to have changed if it no longer exists.+--+monitorFileExistence :: FilePath -> MonitorFilePath+monitorFileExistence = MonitorFile FileExists DirNotExists++-- | Monitor a single directory for changes, based on its modification+-- time. The monitored directory is considered to have changed if it no+-- longer exists or if its modification time has changed.+--+monitorDirectory :: FilePath -> MonitorFilePath+monitorDirectory = MonitorFile FileNotExists DirModTime++-- | Monitor a single non-existent directory for changes.  The monitored+-- directory is considered to have changed if it exists.+--+monitorNonExistentDirectory :: FilePath -> MonitorFilePath+-- Just an alias for monitorNonExistentFile, since you can't+-- tell the difference between a non-existent directory and+-- a non-existent file :)+monitorNonExistentDirectory = monitorNonExistentFile++-- | Monitor a single directory for existence. The monitored directory is+-- considered to have changed only if it no longer exists.+--+monitorDirectoryExistence :: FilePath -> MonitorFilePath+monitorDirectoryExistence = MonitorFile FileNotExists DirExists++-- | Monitor a single file or directory for changes, based on its modification+-- time. The monitored file is considered to have changed if it no longer+-- exists or if its modification time has changed.+--+monitorFileOrDirectory :: FilePath -> MonitorFilePath+monitorFileOrDirectory = MonitorFile FileModTime DirModTime++-- | Monitor a set of files (or directories) identified by a file glob.+-- The monitored glob is considered to have changed if the set of files+-- matching the glob changes (i.e. creations or deletions), or for files if the+-- modification time and content hash of any matching file has changed.+--+monitorFileGlob :: FilePathGlob -> MonitorFilePath+monitorFileGlob = MonitorFileGlob FileHashed DirExists++-- | Monitor a set of files (or directories) identified by a file glob for+-- existence only. The monitored glob is considered to have changed if the set+-- of files matching the glob changes (i.e. creations or deletions).+--+monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath+monitorFileGlobExistence = MonitorFileGlob FileExists DirExists++-- | Creates a list of files to monitor when you search for a file which+-- unsuccessfully looked in @notFoundAtPaths@ before finding it at+-- @foundAtPath@.+monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileSearchPath notFoundAtPaths foundAtPath =+    monitorFile foundAtPath+  : map monitorNonExistentFile notFoundAtPaths++-- | Similar to 'monitorFileSearchPath', but also instructs us to+-- monitor the hash of the found file.+monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]+monitorFileHashedSearchPath notFoundAtPaths foundAtPath =+    monitorFileHashed foundAtPath+  : map monitorNonExistentFile notFoundAtPaths+++------------------------------------------------------------------------------+-- Implementation types, files status+--++-- | The state necessary to determine whether a set of monitored+-- files has changed.  It consists of two parts: a set of specific+-- files to be monitored (index by their path), and a list of+-- globs, which monitor may files at once.+data MonitorStateFileSet+   = MonitorStateFileSet ![MonitorStateFile]+                         ![MonitorStateGlob]+     -- Morally this is not actually a set but a bag (represented by lists).+     -- There is no principled reason to use a bag here rather than a set, but+     -- there is also no particular gain either. That said, we do preserve the+     -- order of the lists just to reduce confusion (and have predictable I/O+     -- patterns).+  deriving (Show, Generic)++instance Binary MonitorStateFileSet+instance Structured MonitorStateFileSet++type Hash = Int++-- | The state necessary to determine whether a monitored file has changed.+--+-- This covers all the cases of 'MonitorFilePath' except for globs which is+-- covered separately by 'MonitorStateGlob'.+--+-- The @Maybe ModTime@ is to cover the case where we already consider the+-- file to have changed, either because it had already changed by the time we+-- did the snapshot (i.e. too new, changed since start of update process) or it+-- no longer exists at all.+--+data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir+                                         !FilePath !MonitorStateFileStatus+  deriving (Show, Generic)++data MonitorStateFileStatus+   = MonitorStateFileExists+   | MonitorStateFileModTime !ModTime        -- ^ cached file mtime+   | MonitorStateFileHashed  !ModTime !Hash  -- ^ cached mtime and content hash+   | MonitorStateDirExists+   | MonitorStateDirModTime  !ModTime        -- ^ cached dir mtime+   | MonitorStateNonExistent+   | MonitorStateAlreadyChanged+  deriving (Show, Generic)++instance Binary MonitorStateFile+instance Binary MonitorStateFileStatus+instance Structured MonitorStateFile+instance Structured MonitorStateFileStatus++-- | The state necessary to determine whether the files matched by a globbing+-- match have changed.+--+data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir+                                         !FilePathRoot !MonitorStateGlobRel+  deriving (Show, Generic)++data MonitorStateGlobRel+   = MonitorStateGlobDirs+       !Glob !FilePathGlobRel+       !ModTime+       ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted++   | MonitorStateGlobFiles+       !Glob+       !ModTime+       ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted++   | MonitorStateGlobDirTrailing+  deriving (Show, Generic)++instance Binary MonitorStateGlob+instance Binary MonitorStateGlobRel++instance Structured MonitorStateGlob+instance Structured MonitorStateGlobRel++-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by+-- inspecting the state of the file system, and we can go in the reverse+-- direction by just forgetting the extra info.+--+reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]+reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =+    map getSinglePath singlePaths+ ++ map getGlobPath globPaths+  where+    getSinglePath (MonitorStateFile kindfile kinddir filepath _) =+      MonitorFile kindfile kinddir filepath++    getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =+      MonitorFileGlob kindfile kinddir $ FilePathGlob root $+        case gstate of+          MonitorStateGlobDirs  glob globs _ _ -> GlobDir  glob globs+          MonitorStateGlobFiles glob       _ _ -> GlobFile glob+          MonitorStateGlobDirTrailing          -> GlobDirTrailing++------------------------------------------------------------------------------+-- Checking the status of monitored files+--++-- | A monitor for detecting changes to a set of files. It can be used to+-- efficiently test if any of a set of files (specified individually or by+-- glob patterns) has changed since some snapshot. In addition, it also checks+-- for changes in a value (of type @a@), and when there are no changes in+-- either it returns a saved value (of type @b@).+--+-- The main use case looks like this: suppose we have some expensive action+-- that depends on certain pure inputs and reads some set of files, and+-- produces some pure result. We want to avoid re-running this action when it+-- would produce the same result. So we need to monitor the files the action+-- looked at, the other pure input values, and we need to cache the result.+-- Then at some later point, if the input value didn't change, and none of the+-- files changed, then we can re-use the cached result rather than re-running+-- the action.+--+-- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance+-- saves state in a disk file, so the file for that has to be specified,+-- making sure it is unique. The pattern is to use 'checkFileMonitorChanged'+-- to see if there's been any change. If there is, re-run the action, keeping+-- track of the files, then use 'updateFileMonitor' to record the current+-- set of files to monitor, the current input value for the action, and the+-- result of the action.+--+-- The typical occurrence of this pattern is captured by 'rerunIfChanged'+-- and the 'Rebuild' monad. More complicated cases may need to use+-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly.+--+data FileMonitor a b+   = FileMonitor {++       -- | The file where this 'FileMonitor' should store its state.+       --+       fileMonitorCacheFile :: FilePath,++       -- | Compares a new cache key with old one to determine if a+       -- corresponding cached value is still valid.+       --+       -- Typically this is just an equality test, but in some+       -- circumstances it can make sense to do things like subset+       -- comparisons.+       --+       -- The first arg is the new value, the second is the old cached value.+       --+       fileMonitorKeyValid :: a -> a -> Bool,++       -- | When this mode is enabled, if 'checkFileMonitorChanged' returns+       -- 'MonitoredValueChanged' then we have the guarantee that no files+       -- changed, that the value change was the only change. In the default+       -- mode no such guarantee is provided which is slightly faster.+       --+       fileMonitorCheckIfOnlyValueChanged :: Bool+  }++-- | Define a new file monitor.+--+-- It's best practice to define file monitor values once, and then use the+-- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this+-- ensures you get the same types @a@ and @b@ for reading and writing.+--+-- The path of the file monitor itself must be unique because it keeps state+-- on disk and these would clash.+--+newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the+                                   -- file monitor. Must be unique.+                       -> FileMonitor a b+newFileMonitor path = FileMonitor path (==) False++-- | The result of 'checkFileMonitorChanged': either the monitored files or+-- value changed (and it tells us which it was) or nothing changed and we get+-- the cached result.+--+data MonitorChanged a b =+     -- | The monitored files and value did not change. The cached result is+     -- @b@.+     --+     -- The set of monitored files is also returned. This is useful+     -- for composing or nesting 'FileMonitor's.+     MonitorUnchanged b [MonitorFilePath]++     -- | The monitor found that something changed. The reason is given.+     --+   | MonitorChanged (MonitorChangedReason a)+  deriving Show++-- | What kind of change 'checkFileMonitorChanged' detected.+--+data MonitorChangedReason a =++     -- | One of the files changed (existence, file type, mtime or file+     -- content, depending on the 'MonitorFilePath' in question)+     MonitoredFileChanged FilePath++     -- | The pure input value changed.+     --+     -- The previous cached key value is also returned. This is sometimes+     -- useful when using a 'fileMonitorKeyValid' function that is not simply+     -- '(==)', when invalidation can be partial. In such cases it can make+     -- sense to 'updateFileMonitor' with a key value that's a combination of+     -- the new and old (e.g. set union).+   | MonitoredValueChanged a++     -- | There was no saved monitor state, cached value etc. Ie the file+     -- for the 'FileMonitor' does not exist.+   | MonitorFirstRun++     -- | There was existing state, but we could not read it. This typically+     -- happens when the code has changed compared to an existing 'FileMonitor'+     -- cache file and type of the input value or cached value has changed such+     -- that we cannot decode the values. This is completely benign as we can+     -- treat is just as if there were no cache file and re-run.+   | MonitorCorruptCache+  deriving (Eq, Show, Functor)++-- | Test if the input value or files monitored by the 'FileMonitor' have+-- changed. If not, return the cached value.+--+-- See 'FileMonitor' for a full explanation.+--+checkFileMonitorChanged+  :: (Binary a, Structured a, Binary b, Structured b)+  => FileMonitor a b            -- ^ cache file path+  -> FilePath                   -- ^ root directory+  -> a                          -- ^ guard or key value+  -> IO (MonitorChanged a b)    -- ^ did the key or any paths change?+checkFileMonitorChanged+    monitor@FileMonitor { fileMonitorKeyValid,+                          fileMonitorCheckIfOnlyValueChanged }+    root currentKey =++    -- Consider it a change if the cache file does not exist,+    -- or we cannot decode it. Sadly ErrorCall can still happen, despite+    -- using decodeFileOrFail, e.g. Data.Char.chr errors++    handleDoesNotExist (MonitorChanged MonitorFirstRun) $+    handleErrorCall    (MonitorChanged MonitorCorruptCache) $+    withCacheFile monitor $+        either (\_ -> return (MonitorChanged MonitorCorruptCache))+               checkStatusCache++  where+    checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do+        change <- checkForChanges+        case change of+          Just reason -> return (MonitorChanged reason)+          Nothing     -> case cachedResult of+                            Left _ -> pure (MonitorChanged MonitorCorruptCache)+                            Right cr -> return (MonitorUnchanged cr monitorFiles)+            where monitorFiles = reconstructMonitorFilePaths cachedFileStatus+      where+        -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that+        -- if we return MonitoredValueChanged that only the value changed.+        -- We do that by checkin for file changes first. Otherwise it makes+        -- more sense to do the cheaper test first.+        checkForChanges+          | fileMonitorCheckIfOnlyValueChanged+          = checkFileChange cachedFileStatus cachedKey cachedResult+              `mplusMaybeT`+            checkValueChange cachedKey++          | otherwise+          = checkValueChange cachedKey+              `mplusMaybeT`+            checkFileChange cachedFileStatus cachedKey cachedResult++    mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+    mplusMaybeT ma mb = do+      mx <- ma+      case mx of+        Nothing -> mb+        Just x  -> return (Just x)++    -- Check if the guard value has changed+    checkValueChange cachedKey+      | not (fileMonitorKeyValid currentKey cachedKey)+      = return (Just (MonitoredValueChanged cachedKey))+      | otherwise+      = return Nothing++    -- Check if any file has changed+    checkFileChange cachedFileStatus cachedKey cachedResult = do+      res <- probeFileSystem root cachedFileStatus+      case res of+        -- Some monitored file has changed+        Left changedPath ->+          return (Just (MonitoredFileChanged (normalise changedPath)))++        -- No monitored file has changed+        Right (cachedFileStatus', cacheStatus) -> do++          -- But we might still want to update the cache+          whenCacheChanged cacheStatus $+            case cachedResult of+              Left _ -> pure ()+              Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr++          return Nothing++-- | Lazily decode a triple, parsing the first two fields strictly and+-- returning a lazy value containing either the last one or an error.+-- This is helpful for cabal cache files where the first two components+-- contain header data that lets one test if the cache is still valid,+-- and the last (potentially large) component is the cached value itself.+-- This way we can test for cache validity without needing to pay the+-- cost of the decode of stale cache data. This lives here rather than+-- Distribution.Utils.Structured because it depends on a newer version of+-- binary than supported in the Cabal library proper.+structuredDecodeTriple+  :: forall a b c. (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c)+  => BS.ByteString -> Either String (a, b, Either String c)+structuredDecodeTriple lbs =+  let partialDecode =+         (`runGetOrFail` lbs) $ do+            (_ :: Tag (a,b,c)) <- Binary.get+            (a :: a) <- Binary.get+            (b :: b) <- Binary.get+            pure (a, b)+      cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)+      cleanEither (Right (_,_,v))     = Right v++  in case partialDecode of+       Left (_, pos, msg) ->  Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)+       Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs')++-- | Helper for reading the cache file.+--+-- This determines the type and format of the binary cache file.+--+withCacheFile :: (Binary a, Structured a, Binary b, Structured b)+              => FileMonitor a b+              -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r)+              -> IO r+withCacheFile (FileMonitor {fileMonitorCacheFile}) k =+    withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do+        contents <- structuredDecodeTriple <$> BS.hGetContents hnd+        k contents++-- | Helper for writing the cache file.+--+-- This determines the type and format of the binary cache file.+--+rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b)+                 => FileMonitor a b+                 -> MonitorStateFileSet -> a -> b -> IO ()+rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =+    writeFileAtomic fileMonitorCacheFile $+        structuredEncode (fileset, key, result)++-- | Probe the file system to see if any of the monitored files have changed.+--+-- It returns Nothing if any file changed, or returns a possibly updated+-- file 'MonitorStateFileSet' plus an indicator of whether it actually changed.+--+-- We may need to update the cache since there may be changes in the filesystem+-- state which don't change any of our affected files.+--+-- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a+-- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run+-- and find @proj2@ was created, yet contains no files matching @*.cabal@ then+-- we want to update the cache despite no changes in our relevant file set.+-- Specifically, we should add an mtime for this directory so we can avoid+-- re-traversing the directory in future runs.+--+probeFileSystem :: FilePath -> MonitorStateFileSet+                -> IO (Either FilePath (MonitorStateFileSet, CacheChanged))+probeFileSystem root (MonitorStateFileSet singlePaths globPaths) =+  runChangedM $ do+    sequence_+      [ probeMonitorStateFileStatus root file status+      | MonitorStateFile _ _ file status <- singlePaths ]+    -- The glob monitors can require state changes+    globPaths' <-+      sequence+        [ probeMonitorStateGlob root globPath+        | globPath <- globPaths ]+    return (MonitorStateFileSet singlePaths globPaths')+++-----------------------------------------------+-- Monad for checking for file system changes+--+-- We need to be able to bail out if we detect a change (using ExceptT),+-- but if there's no change we need to be able to rebuild the monitor+-- state. And we want to optimise that rebuilding by keeping track if+-- anything actually changed (using StateT), so that in the typical case+-- we can avoid rewriting the state file.++newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged))+runChangedM (ChangedM action) =+  runExceptT $ State.runStateT action CacheUnchanged++somethingChanged :: FilePath -> ChangedM a+somethingChanged path = ChangedM $ throwError path++cacheChanged :: ChangedM ()+cacheChanged = ChangedM $ State.put CacheChanged++mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a+mapChangedFile adjust (ChangedM a) =+    ChangedM (mapStateT (withExceptT adjust) a)++data CacheChanged = CacheChanged | CacheUnchanged++whenCacheChanged :: Monad m => CacheChanged -> m () -> m ()+whenCacheChanged CacheChanged action = action+whenCacheChanged CacheUnchanged _    = return ()++----------------------++-- | Probe the file system to see if a single monitored file has changed.+--+probeMonitorStateFileStatus :: FilePath -> FilePath+                            -> MonitorStateFileStatus+                            -> ChangedM ()+probeMonitorStateFileStatus root file status =+    case status of+      MonitorStateFileExists ->+        probeFileExistence root file++      MonitorStateFileModTime mtime ->+        probeFileModificationTime root file mtime++      MonitorStateFileHashed  mtime hash ->+        probeFileModificationTimeAndHash root file mtime hash++      MonitorStateDirExists ->+        probeDirExistence root file++      MonitorStateDirModTime mtime ->+        probeFileModificationTime root file mtime++      MonitorStateNonExistent ->+        probeFileNonExistence root file++      MonitorStateAlreadyChanged ->+        somethingChanged file+++-- | Probe the file system to see if a monitored file glob has changed.+--+probeMonitorStateGlob :: FilePath      -- ^ root path+                      -> MonitorStateGlob+                      -> ChangedM MonitorStateGlob+probeMonitorStateGlob relroot+                      (MonitorStateGlob kindfile kinddir globroot glob) = do+    root <- liftIO $ getFilePathRootDirectory globroot relroot+    case globroot of+      FilePathRelative ->+        MonitorStateGlob kindfile kinddir globroot <$>+        probeMonitorStateGlobRel kindfile kinddir root "." glob++      -- for absolute cases, make the changed file we report absolute too+      _ ->+        mapChangedFile (root </>) $+        MonitorStateGlob kindfile kinddir globroot <$>+        probeMonitorStateGlobRel kindfile kinddir root "" glob++probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir+                         -> FilePath      -- ^ root path+                         -> FilePath      -- ^ path of the directory we are+                                          --   looking in relative to @root@+                         -> MonitorStateGlobRel+                         -> ChangedM MonitorStateGlobRel+probeMonitorStateGlobRel kindfile kinddir root dirName+                        (MonitorStateGlobDirs glob globPath mtime children) = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    case change of+      Nothing -> do+        children' <- sequence+          [ do fstate' <- probeMonitorStateGlobRel+                            kindfile kinddir root+                            (dirName </> fname) fstate+               return (fname, fstate')+          | (fname, fstate) <- children ]+        return $! MonitorStateGlobDirs glob globPath mtime children'++      Just mtime' -> do+        -- directory modification time changed:+        -- a matching subdir may have been added or deleted+        matches <- filterM (\entry -> let subdir = root </> dirName </> entry+                                       in liftIO $ doesDirectoryExist subdir)+                 . filter (matchGlob glob)+               =<< liftIO (getDirectoryContents (root </> dirName))++        children' <- traverse probeMergeResult $+                          mergeBy (\(path1,_) path2 -> compare path1 path2)+                                  children+                                  (sort matches)+        return $! MonitorStateGlobDirs glob globPath mtime' children'+        -- Note that just because the directory has changed, we don't force+        -- a cache rewrite with 'cacheChanged' since that has some cost, and+        -- all we're saving is scanning the directory. But we do rebuild the+        -- cache with the new mtime', so that if the cache is rewritten for+        -- some other reason, we'll take advantage of that.++  where+    probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath+                     -> ChangedM (FilePath, MonitorStateGlobRel)++    -- Only in cached (directory deleted)+    probeMergeResult (OnlyInLeft (path, fstate)) = do+      case allMatchingFiles (dirName </> path) fstate of+        [] -> return (path, fstate)+        -- Strictly speaking we should be returning 'CacheChanged' above+        -- as we should prune the now-missing 'MonitorStateGlobRel'. However+        -- we currently just leave these now-redundant entries in the+        -- cache as they cost no IO and keeping them allows us to avoid+        -- rewriting the cache.+        (file:_) -> somethingChanged file++    -- Only in current filesystem state (directory added)+    probeMergeResult (OnlyInRight path) = do+      fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty+                           kindfile kinddir root (dirName </> path) globPath+      case allMatchingFiles (dirName </> path) fstate of+        (file:_) -> somethingChanged file+        -- This is the only case where we use 'cacheChanged' because we can+        -- have a whole new dir subtree (of unbounded size and cost), so we+        -- need to save the state of that new subtree in the cache.+        [] -> cacheChanged >> return (path, fstate)++    -- Found in path+    probeMergeResult (InBoth (path, fstate) _) = do+      fstate' <- probeMonitorStateGlobRel kindfile kinddir+                                          root (dirName </> path) fstate+      return (path, fstate')++    -- | Does a 'MonitorStateGlob' have any relevant files within it?+    allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]+    allMatchingFiles dir (MonitorStateGlobFiles _ _   entries) =+      [ dir </> fname | (fname, _) <- entries ]+    allMatchingFiles dir (MonitorStateGlobDirs  _ _ _ entries) =+      [ res+      | (subdir, fstate) <- entries+      , res <- allMatchingFiles (dir </> subdir) fstate ]+    allMatchingFiles dir MonitorStateGlobDirTrailing =+      [dir]++probeMonitorStateGlobRel _ _ root dirName+                         (MonitorStateGlobFiles glob mtime children) = do+    change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime+    mtime' <- case change of+      Nothing     -> return mtime+      Just mtime' -> do+        -- directory modification time changed:+        -- a matching file may have been added or deleted+        matches <- return . filter (matchGlob glob)+               =<< liftIO (getDirectoryContents (root </> dirName))++        traverse_ probeMergeResult $+              mergeBy (\(path1,_) path2 -> compare path1 path2)+                      children+                      (sort matches)+        return mtime'++    -- Check that none of the children have changed+    for_ children $ \(file, status) ->+      probeMonitorStateFileStatus root (dirName </> file) status+++    return (MonitorStateGlobFiles glob mtime' children)+    -- Again, we don't force a cache rewite with 'cacheChanged', but we do use+    -- the new mtime' if any.+  where+    probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath+                     -> ChangedM ()+    probeMergeResult mr = case mr of+      InBoth _ _            -> return ()+    -- this is just to be able to accurately report which file changed:+      OnlyInLeft  (path, _) -> somethingChanged (dirName </> path)+      OnlyInRight path      -> somethingChanged (dirName </> path)++probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =+    return MonitorStateGlobDirTrailing++------------------------------------------------------------------------------++-- | Update the input value and the set of files monitored by the+-- 'FileMonitor', plus the cached value that may be returned in future.+--+-- This takes a snapshot of the state of the monitored files right now, so+-- 'checkFileMonitorChanged' will look for file system changes relative to+-- this snapshot.+--+-- This is typically done once the action has been completed successfully and+-- we have the action's result and we know what files it looked at. See+-- 'FileMonitor' for a full explanation.+--+-- If we do take the snapshot after the action has completed then we have a+-- problem. The problem is that files might have changed /while/ the action was+-- running but /after/ the action read them. If we take the snapshot after the+-- action completes then we will miss these changes. The solution is to record+-- a timestamp before beginning execution of the action and then we make the+-- conservative assumption that any file that has changed since then has+-- already changed, ie the file monitor state for these files will be such that+-- 'checkFileMonitorChanged' will report that they have changed.+--+-- So if you do use 'updateFileMonitor' after the action (so you can discover+-- the files used rather than predicting them in advance) then use+-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively,+-- if you take the snapshot in advance of the action, or you're not monitoring+-- any files then you can use @Nothing@ for the timestamp parameter.+--+updateFileMonitor+  :: (Binary a, Structured a, Binary b, Structured b)+  => FileMonitor a b          -- ^ cache file path+  -> FilePath                 -- ^ root directory+  -> Maybe MonitorTimestamp   -- ^ timestamp when the update action started+  -> [MonitorFilePath]        -- ^ files of interest relative to root+  -> a                        -- ^ the current key value+  -> b                        -- ^ the current result value+  -> IO ()+updateFileMonitor monitor root startTime monitorFiles+                  cachedKey cachedResult = do+    hashcache <- readCacheFileHashes monitor+    msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles+    rewriteCacheFile monitor msfs cachedKey cachedResult++-- | A timestamp to help with the problem of file changes during actions.+-- See 'updateFileMonitor' for details.+--+newtype MonitorTimestamp = MonitorTimestamp ModTime++-- | Record a timestamp at the beginning of an action, and when the action+-- completes call 'updateFileMonitor' passing it the timestamp.+-- See 'updateFileMonitor' for details.+--+beginUpdateFileMonitor :: IO MonitorTimestamp+beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime++-- | Take the snapshot of the monitored files. That is, given the+-- specification of the set of files we need to monitor, inspect the state+-- of the file system now and collect the information we'll need later to+-- determine if anything has changed.+--+buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp+                                              -- of the start of the action+                         -> FileHashCache     -- ^ existing file hashes+                         -> FilePath          -- ^ root directory+                         -> [MonitorFilePath] -- ^ patterns of interest+                                              --   relative to root+                         -> IO MonitorStateFileSet+buildMonitorStateFileSet mstartTime hashcache root =+    go [] []+  where+    go :: [MonitorStateFile] -> [MonitorStateGlob]+       -> [MonitorFilePath] -> IO MonitorStateFileSet+    go !singlePaths !globPaths [] =+      return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths))++    go !singlePaths !globPaths+       (MonitorFile kindfile kinddir path : monitors) = do+      monitorState <- MonitorStateFile kindfile kinddir path+                  <$> buildMonitorStateFile mstartTime hashcache+                                            kindfile kinddir root path+      go (monitorState : singlePaths) globPaths monitors++    go !singlePaths !globPaths+       (MonitorFileGlob kindfile kinddir globPath : monitors) = do+      monitorState <- buildMonitorStateGlob mstartTime hashcache+                                            kindfile kinddir root globPath+      go singlePaths (monitorState : globPaths) monitors+++buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update+                      -> FileHashCache          -- ^ existing file hashes+                      -> MonitorKindFile -> MonitorKindDir+                      -> FilePath               -- ^ the root directory+                      -> FilePath+                      -> IO MonitorStateFileStatus+buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do+    let abspath = root </> path+    isFile <- doesFileExist abspath+    isDir  <- doesDirectoryExist abspath+    case (isFile, kindfile, isDir, kinddir) of+      (_, FileNotExists, _, DirNotExists) ->+        -- we don't need to care if it exists now, since we check at probe time+        return MonitorStateNonExistent++      (False, _, False, _) ->+        return MonitorStateAlreadyChanged++      (True, FileExists, _, _)  ->+        return MonitorStateFileExists++      (True, FileModTime, _, _) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else return (MonitorStateFileModTime mtime)++      (True, FileHashed, _, _) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else do hash <- getFileHash hashcache abspath abspath mtime+                    return (MonitorStateFileHashed mtime hash)++      (_, _, True, DirExists) ->+        return MonitorStateDirExists++      (_, _, True, DirModTime) ->+        handleIOException MonitorStateAlreadyChanged $ do+          mtime <- getModTime abspath+          if changedDuringUpdate mstartTime mtime+            then return MonitorStateAlreadyChanged+            else return (MonitorStateDirModTime mtime)++      (False, _, True,  DirNotExists) -> return MonitorStateAlreadyChanged+      (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged++-- | If we have a timestamp for the beginning of the update, then any file+-- mtime later than this means that it changed during the update and we ought+-- to consider the file as already changed.+--+changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool+changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime+                        = mtime > startTime+changedDuringUpdate _ _ = False++-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case+-- of a file glob.+--+-- This gets used both by 'buildMonitorStateFileSet' when we're taking the+-- file system snapshot, but also by 'probeGlobStatus' as part of checking+-- the monitored (globed) files for changes when we find a whole new subtree.+--+buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update+                      -> FileHashCache     -- ^ existing file hashes+                      -> MonitorKindFile -> MonitorKindDir+                      -> FilePath     -- ^ the root directory+                      -> FilePathGlob -- ^ the matching glob+                      -> IO MonitorStateGlob+buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot+                      (FilePathGlob globroot globPath) = do+    root <- liftIO $ getFilePathRootDirectory globroot relroot+    MonitorStateGlob kindfile kinddir globroot <$>+      buildMonitorStateGlobRel+        mstartTime hashcache kindfile kinddir root "." globPath++buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update+                         -> FileHashCache   -- ^ existing file hashes+                         -> MonitorKindFile -> MonitorKindDir+                         -> FilePath        -- ^ the root directory+                         -> FilePath        -- ^ directory we are examining+                                            --   relative to the root+                         -> FilePathGlobRel -- ^ the matching glob+                         -> IO MonitorStateGlobRel+buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root+                         dir globPath = do+    let absdir = root </> dir+    dirEntries <- getDirectoryContents absdir+    dirMTime   <- getModTime absdir+    case globPath of+      GlobDir glob globPath' -> do+        subdirs <- filterM (\subdir -> doesDirectoryExist (absdir </> subdir))+                 $ filter (matchGlob glob) dirEntries+        subdirStates <-+          for (sort subdirs) $ \subdir -> do+            fstate <- buildMonitorStateGlobRel+                        mstartTime hashcache kindfile kinddir root+                        (dir </> subdir) globPath'+            return (subdir, fstate)+        return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates++      GlobFile glob -> do+        let files = filter (matchGlob glob) dirEntries+        filesStates <-+          for (sort files) $ \file -> do+            fstate <- buildMonitorStateFile+                        mstartTime hashcache kindfile kinddir root+                        (dir </> file)+            return (file, fstate)+        return $! MonitorStateGlobFiles glob dirMTime filesStates++      GlobDirTrailing ->+        return MonitorStateGlobDirTrailing+++-- | We really want to avoid re-hashing files all the time. We already make+-- the assumption that if a file mtime has not changed then we don't need to+-- bother checking if the content hash has changed. We can apply the same+-- assumption when updating the file monitor state. In the typical case of+-- updating a file monitor the set of files is the same or largely the same so+-- we can grab the previously known content hashes with their corresponding+-- mtimes.+--+type FileHashCache = Map FilePath (ModTime, Hash)++-- | We declare it a cache hit if the mtime of a file is the same as before.+--+lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash+lookupFileHashCache hashcache file mtime = do+    (mtime', hash) <- Map.lookup file hashcache+    guard (mtime' == mtime)+    return hash++-- | Either get it from the cache or go read the file+getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash+getFileHash hashcache relfile absfile mtime =+    case lookupFileHashCache hashcache relfile mtime of+      Just hash -> return hash+      Nothing   -> readFileHash absfile++-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While+-- in principle we could preserve the structure of the previous state, given+-- that the set of files to monitor can change then it's simpler just to throw+-- away the structure and use a finite map.+--+readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b)+                    => FileMonitor a b -> IO FileHashCache+readCacheFileHashes monitor =+    handleDoesNotExist Map.empty $+    handleErrorCall    Map.empty $+    withCacheFile monitor $ \res ->+      case res of+        Left _             -> return Map.empty+        Right (msfs, _, _) -> return (mkFileHashCache msfs)+  where+    mkFileHashCache :: MonitorStateFileSet -> FileHashCache+    mkFileHashCache (MonitorStateFileSet singlePaths globPaths) =+                    collectAllFileHashes singlePaths+        `Map.union` collectAllGlobHashes globPaths++    collectAllFileHashes singlePaths =+      Map.fromList [ (fpath, (mtime, hash))+                   | MonitorStateFile _ _ fpath+                       (MonitorStateFileHashed mtime hash) <- singlePaths ]++    collectAllGlobHashes globPaths =+      Map.fromList [ (fpath, (mtime, hash))+                   | MonitorStateGlob _ _ _ gstate <- globPaths+                   , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]++    collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =+      [ res+      | (subdir, fstate) <- entries+      , res <- collectGlobHashes (dir </> subdir) fstate ]++    collectGlobHashes dir (MonitorStateGlobFiles  _ _ entries) =+      [ (dir </> fname, (mtime, hash))+      | (fname, MonitorStateFileHashed mtime hash) <- entries ]++    collectGlobHashes _dir MonitorStateGlobDirTrailing =+      []+++------------------------------------------------------------------------------+-- Utils+--++-- | Within the @root@ directory, check if @file@ has its 'ModTime' is+-- the same as @mtime@, short-circuiting if it is different.+probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM ()+probeFileModificationTime root file mtime = do+    unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime+    unless unchanged (somethingChanged file)++-- | Within the @root@ directory, check if @file@ has its 'ModTime' and+-- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is+-- different.+probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash+                                 -> ChangedM ()+probeFileModificationTimeAndHash root file mtime hash = do+    unchanged <- liftIO $+      checkFileModificationTimeAndHashUnchanged root file mtime hash+    unless unchanged (somethingChanged file)++-- | Within the @root@ directory, check if @file@ still exists as a file.+-- If it *does not* exist, short-circuit.+probeFileExistence :: FilePath -> FilePath -> ChangedM ()+probeFileExistence root file = do+    existsFile <- liftIO $ doesFileExist (root </> file)+    unless existsFile (somethingChanged file)++-- | Within the @root@ directory, check if @dir@ still exists.+-- If it *does not* exist, short-circuit.+probeDirExistence :: FilePath -> FilePath -> ChangedM ()+probeDirExistence root dir = do+    existsDir  <- liftIO $ doesDirectoryExist (root </> dir)+    unless existsDir (somethingChanged dir)++-- | Within the @root@ directory, check if @file@ still does not exist.+-- If it *does* exist, short-circuit.+probeFileNonExistence :: FilePath -> FilePath -> ChangedM ()+probeFileNonExistence root file = do+    existsFile <- liftIO $ doesFileExist (root </> file)+    existsDir  <- liftIO $ doesDirectoryExist (root </> file)+    when (existsFile || existsDir) (somethingChanged file)++-- | Returns @True@ if, inside the @root@ directory, @file@ has the same+-- 'ModTime' as @mtime@.+checkModificationTimeUnchanged :: FilePath -> FilePath+                               -> ModTime -> IO Bool+checkModificationTimeUnchanged root file mtime =+  handleIOException False $ do+    mtime' <- getModTime (root </> file)+    return (mtime == mtime')++-- | Returns @True@ if, inside the @root@ directory, @file@ has the+-- same 'ModTime' and 'Hash' as @mtime and @chash@.+checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath+                                          -> ModTime -> Hash -> IO Bool+checkFileModificationTimeAndHashUnchanged root file mtime chash =+  handleIOException False $ do+    mtime' <- getModTime (root </> file)+    if mtime == mtime'+      then return True+      else do+        chash' <- readFileHash (root </> file)+        return (chash == chash')++-- | Read a non-cryptographic hash of a @file@.+readFileHash :: FilePath -> IO Hash+readFileHash file =+    withBinaryFile file ReadMode $ \hnd ->+      evaluate . Hashable.hash =<< BS.hGetContents hnd++-- | Given a directory @dir@, return @Nothing@ if its 'ModTime'+-- is the same as @mtime@, and the new 'ModTime' if it is not.+checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime)+checkDirectoryModificationTime dir mtime =+  handleIOException Nothing $ do+    mtime' <- getModTime dir+    if mtime == mtime'+      then return Nothing+      else return (Just mtime')++-- | Run an IO computation, returning the first argument @e@ if there is an 'error'+-- call. ('ErrorCall')+handleErrorCall :: a -> IO a -> IO a+handleErrorCall e = handle handler where+#if MIN_VERSION_base(4,9,0)+    handler (ErrorCallWithLocation _ _) = return e+#else+    handler (ErrorCall _) = return e+#endif+++-- | Run an IO computation, returning @e@ if there is any 'IOException'.+--+-- This policy is OK in the file monitor code because it just causes the+-- monitor to report that something changed, and then code reacting to that+-- will normally encounter the same IO exception when it re-runs the action+-- that uses the file.+--+handleIOException :: a -> IO a -> IO a+handleIOException e =+    handle (anyIOException e)+  where+    anyIOException :: a -> IOException -> IO a+    anyIOException x _ = return x+++------------------------------------------------------------------------------+-- Instances+--
+ src/Distribution/Client/Freeze.hs view
@@ -0,0 +1,266 @@+-----------------------------------------------------------------------------+-- |+-- 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, getFreezePkgs+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.Config ( SavedConfig(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.SolverInstallPlan+         ( SolverInstallPlan, SolverPlanPackage )+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import Distribution.Client.Setup+         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)+         , RepoContext(..) )+import Distribution.Client.Sandbox.PackageEnvironment+         ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,+           userPackageEnvironmentFile )++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.OptionalStanza+import Distribution.Solver.Types.PkgConfigDb+import Distribution.Solver.Types.SolverId++import Distribution.Package+         ( Package, packageId, packageName, packageVersion )+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo, PackageDBStack )+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.Simple.Program+         ( ProgramDb )+import Distribution.Simple.Setup+         ( fromFlag, fromFlagOrDefault, flagToMaybe )+import Distribution.Simple.Utils+         ( die', notice, debug, writeFileAtomic, toUTF8LBS)+import Distribution.System+         ( Platform )++import Distribution.Version+         ( thisVersion )++-- ------------------------------------------------------------+-- * The freeze command+-- ------------------------------------------------------------++-- | Freeze all of the dependencies by writing a constraints section+-- constraining each dependency to an exact version.+--+freeze :: Verbosity+       -> PackageDBStack+       -> RepoContext+       -> Compiler+       -> Platform+       -> ProgramDb+       -> GlobalFlags+       -> FreezeFlags+       -> IO ()+freeze verbosity packageDBs repoCtxt comp platform progdb+      globalFlags freezeFlags = do++    pkgs  <- getFreezePkgs+               verbosity packageDBs repoCtxt comp platform progdb+               globalFlags freezeFlags++    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 globalFlags pkgs++  where+    dryRun = fromFlag (freezeDryRun freezeFlags)++-- | Get the list of packages whose versions would be frozen by the @freeze@+-- command.+getFreezePkgs :: Verbosity+              -> PackageDBStack+              -> RepoContext+              -> Compiler+              -> Platform+              -> ProgramDb+              -> GlobalFlags+              -> FreezeFlags+              -> IO [SolverPlanPackage]+getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb+      globalFlags freezeFlags = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt+    pkgConfigDb       <- readPkgConfigDb      verbosity progdb++    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       [UserTargetLocalDir "."]++    sanityCheck pkgSpecifiers+    planPackages+               verbosity comp platform freezeFlags+               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers+  where+    sanityCheck pkgSpecifiers = do+      when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $+        die' verbosity $ "internal error: 'resolveUserTargets' returned "+           ++ "unexpected named package specifiers!"+      when (length pkgSpecifiers /= 1) $+        die' verbosity $ "internal error: 'resolveUserTargets' returned "+           ++ "unexpected source package specifiers!"++planPackages :: Verbosity+             -> Compiler+             -> Platform+             -> FreezeFlags+             -> InstalledPackageIndex+             -> SourcePackageDb+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> IO [SolverPlanPackage]+planPackages verbosity comp platform freezeFlags+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do++  solver <- chooseSolver verbosity+            (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)+  notice verbosity "Resolving dependencies..."++  installPlan <- foldProgress logMsg (die' verbosity) return $+                   resolveDependencies+                     platform (compilerInfo comp) pkgConfigDb+                     solver+                     resolverParams++  return $ pruneInstallPlan installPlan pkgSpecifiers++  where+    resolverParams =++        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setCountConflicts countConflicts++      . setFineGrainedConflicts fineGrainedConflicts++      . setMinimizeConflictSet minimizeConflictSet++      . setShadowPkgs shadowPkgs++      . setStrongFlags strongFlags++      . setAllowBootLibInstalls allowBootLibInstalls++      . setOnlyConstrained onlyConstrained++      . setSolverVerbosity verbosity++      . addConstraints+          [ let pkg = pkgSpecifierTarget pkgSpecifier+                pc = PackageConstraint (scopeToplevel pkg)+                                       (PackagePropertyStanzas stanzas)+            in LabeledPackageConstraint pc ConstraintSourceFreeze+          | pkgSpecifier <- pkgSpecifiers ]++      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++    logMsg message rest = debug verbosity message >> rest++    stanzas = [ TestStanzas | testsEnabled ]+           ++ [ BenchStanzas | benchmarksEnabled ]+    testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags+    benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags++    reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)+    countConflicts   = fromFlag (freezeCountConflicts   freezeFlags)+    fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags)+    minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags)+    independentGoals = fromFlag (freezeIndependentGoals freezeFlags)+    shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)+    strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)+    maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)+    allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)+    onlyConstrained  = fromFlag (freezeOnlyConstrained  freezeFlags)+++-- | Remove all unneeded packages from an install plan.+--+-- A package is unneeded if it is either+--+-- 1) the package that we are freezing, or+--+-- 2) not a dependency (directly or transitively) of the package we are+--    freezing.  This is useful for removing previously installed packages+--    which are no longer required from the install plan.+--+-- Invariant: @pkgSpecifiers@ must refer to packages which are not+-- 'PreExisting' in the 'SolverInstallPlan'.+pruneInstallPlan :: SolverInstallPlan+                 -> [PackageSpecifier UnresolvedSourcePackage]+                 -> [SolverPlanPackage]+pruneInstallPlan installPlan pkgSpecifiers =+    removeSelf pkgIds $+    SolverInstallPlan.dependencyClosure installPlan pkgIds+  where+    pkgIds = [ PlannedId (packageId pkg)+             | SpecificSourcePackage pkg <- pkgSpecifiers ]+    removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)+    removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "+                         ++ "unexpected package specifiers!"+++freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()+freezePackages verbosity globalFlags pkgs = do++    pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $+                   loadUserConfig verbosity ""+                   (flagToMaybe . globalConstraintsFile $ globalFlags)+    writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv+  where+    addFrozenConstraints config =+        config {+            savedConfigureExFlags = (savedConfigureExFlags config) {+                configExConstraints = map constraint pkgs+            }+        }+    constraint pkg =+        (pkgIdToConstraint $ packageId pkg+        ,ConstraintSourceUserConfig userPackageEnvironmentFile)+      where+        pkgIdToConstraint pkgId =+            UserConstraint (UserQualified UserQualToplevel (packageName pkgId))+                           (PackagePropertyVersion $ thisVersion (packageVersion pkgId))+    createPkgEnv config = mempty { pkgEnvSavedConfig = config }+    showPkgEnv = toUTF8LBS . showPackageEnvironment+++formatPkgs :: Package pkg => [pkg] -> [String]+formatPkgs = map $ showPkg . packageId+  where+    showPkg pid = name pid ++ " == " ++ version pid+    name = prettyShow . packageName+    version = prettyShow . packageVersion
+ src/Distribution/Client/GZipUtils.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.GZipUtils+-- Copyright   :  (c) Dmitry Astapov 2010+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Provides a convenience functions for working with files that may or may not+-- be zipped.+-----------------------------------------------------------------------------+module Distribution.Client.GZipUtils (+    maybeDecompress,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Codec.Compression.Zlib.Internal+import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk))++#ifndef MIN_VERSION_zlib+#define MIN_VERSION_zlib(x,y,z) 1+#endif++#if MIN_VERSION_zlib(0,6,0)+import Control.Exception (throw)+import Control.Monad.ST.Lazy (ST, runST)+import qualified Data.ByteString as Strict+#endif++-- | Attempts to decompress the `bytes' under the assumption that+-- "data format" error at the very beginning of the stream means+-- that it is already decompressed. Caller should make sanity checks+-- to verify that it is not, in fact, garbage.+--+-- This is to deal with http proxies that lie to us and transparently+-- decompress without removing the content-encoding header. See:+-- <https://github.com/haskell/cabal/issues/678>+--+maybeDecompress :: ByteString -> ByteString+#if MIN_VERSION_zlib(0,6,0)+maybeDecompress bytes = runST (go bytes decompressor)+  where+    decompressor :: DecompressStream (ST s)+    decompressor = decompressST gzipOrZlibFormat defaultDecompressParams++    -- DataError at the beginning of the stream probably means that stream is+    -- not compressed, so we return it as-is.+    -- TODO: alternatively, we might consider looking for the two magic bytes+    -- at the beginning of the gzip header.  (not an option for zlib, though.)+    go :: Monad m => ByteString -> DecompressStream m -> m ByteString+    go cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k+    go _  (DecompressStreamEnd       _bs ) = return Empty+    go _  (DecompressStreamError _err    ) = return bytes+    go cs (DecompressInputRequired      k) = go cs' =<< k c+      where+        (c, cs') = uncons cs++    -- Once we have received any output though we regard errors as actual errors+    -- and we throw them (as pure exceptions).+    -- TODO: We could (and should) avoid these pure exceptions.+    go' :: Monad m => ByteString -> DecompressStream m -> m ByteString+    go' cs (DecompressOutputAvailable bs k) = liftM (Chunk bs) $ go' cs =<< k+    go' _  (DecompressStreamEnd       _bs ) = return Empty+    go' _  (DecompressStreamError err     ) = throw err+    go' cs (DecompressInputRequired      k) = go' cs' =<< k c+      where+        (c, cs') = uncons cs++    uncons :: ByteString -> (Strict.ByteString, ByteString)+    uncons Empty        = (Strict.empty, Empty)+    uncons (Chunk c cs) = (c, cs)+#else+maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes+  where+    -- DataError at the beginning of the stream probably means that stream is not compressed.+    -- Returning it as-is.+    -- TODO: alternatively, we might consider looking for the two magic bytes+    -- at the beginning of the gzip header.+    foldStream (StreamError _ _) = bytes+    foldStream somethingElse = doFold somethingElse++    doFold StreamEnd               = BS.Empty+    doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)+    doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg+#endif
+ src/Distribution/Client/GenBounds.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.GenBounds+-- Copyright   :  (c) Doug Beardsley 2015+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal gen-bounds command for generating PVP-compliant version bounds.+-----------------------------------------------------------------------------+module Distribution.Client.GenBounds (+    genBounds+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.Init+         ( incVersion )+import Distribution.Client.Freeze+         ( getFreezePkgs )+import Distribution.Client.Setup+         ( GlobalFlags(..), FreezeFlags(..), RepoContext )+import Distribution.Package+         ( Package(..), unPackageName, packageName, packageVersion )+import Distribution.PackageDescription+         ( enabledBuildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePD )+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+import Distribution.Types.ComponentRequestedSpec+         ( defaultComponentRequestedSpec )+import Distribution.Types.Dependency+import Distribution.Simple.Compiler+         ( Compiler, PackageDBStack, compilerInfo )+import Distribution.Simple.Program+         ( ProgramDb )+import Distribution.Simple.Utils+         ( tryFindPackageDesc )+import Distribution.System+         ( Platform )+import Distribution.Version+         ( Version, alterVersion, VersionInterval (..)+         , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals+         , orLaterVersion, earlierVersion, intersectVersionRanges, hasUpperBound)+import System.Directory+         ( getCurrentDirectory )++-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- Example: @0.4.1.2@ produces the version range @>= 0.4.1 && < 0.5@.+--+-- This version is slightly different than the one in+-- 'Distribution.Client.Init'.  This one uses a.b.c as the lower bound because+-- the user could be using a new function introduced in a.b.c which would make+-- ">= a.b" incorrect.+pvpize :: Version -> VersionRange+pvpize v = orLaterVersion (vn 3)+           `intersectVersionRanges`+           earlierVersion (incVersion 1 (vn 2))+  where+    vn n = alterVersion (take n) v++-- | Show the PVP-mandated version range for this package. The @padTo@ parameter+-- specifies the width of the package name column.+showBounds :: Package pkg => Int -> pkg -> String+showBounds padTo p = unwords $+    (padAfter padTo $ unPackageName $ packageName p) :+    -- TODO: use normaliseVersionRange+    map showInterval (asVersionIntervals $ pvpize $ packageVersion p)+  where+    padAfter :: Int -> String -> String+    padAfter n str = str ++ replicate (n - length str) ' '++    showInterval :: VersionInterval -> String+    showInterval (VersionInterval (LowerBound _ _) NoUpperBound) =+      error "Error: expected upper bound...this should never happen!"+    showInterval (VersionInterval (LowerBound l _) (UpperBound u _)) =+      unwords [">=", prettyShow l, "&& <", prettyShow u]++-- | Entry point for the @gen-bounds@ command.+genBounds+    :: Verbosity+    -> PackageDBStack+    -> RepoContext+    -> Compiler+    -> Platform+    -> ProgramDb+    -> GlobalFlags+    -> FreezeFlags+    -> IO ()+genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do +    let cinfo = compilerInfo comp++    cwd <- getCurrentDirectory+    path <- tryFindPackageDesc verbosity cwd+    gpd <- readGenericPackageDescription verbosity path+    -- NB: We don't enable tests or benchmarks, since often they+    -- don't really have useful bounds.+    let epd = finalizePD mempty defaultComponentRequestedSpec+                    (const True) platform cinfo [] gpd+    case epd of+      Left _ -> putStrLn "finalizePD failed"+      Right (pd,_) -> do+        let needBounds = filter (not . hasUpperBound . depVersion) $+                         enabledBuildDepends pd defaultComponentRequestedSpec++        if (null needBounds)+          then putStrLn+               "Congratulations, all your dependencies have upper bounds!"+          else go needBounds+  where+     go needBounds = do+       pkgs  <- getFreezePkgs+                  verbosity packageDBs repoCtxt comp platform progdb+                  globalFlags freezeFlags++       putStrLn boundsNeededMsg++       let isNeeded pkg = unPackageName (packageName pkg)+                          `elem` map depName needBounds+       let thePkgs = filter isNeeded pkgs++       let padTo = maximum $ map (length . unPackageName . packageName) pkgs+       traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs++     depName :: Dependency -> String+     depName (Dependency pn _ _) = unPackageName pn++     depVersion :: Dependency -> VersionRange+     depVersion (Dependency _ vr _) = vr++-- | The message printed when some dependencies are found to be lacking proper+-- PVP-mandated bounds.+boundsNeededMsg :: String+boundsNeededMsg = unlines+  [ ""+  , "The following packages need bounds and here is a suggested starting point."+  , "You can copy and paste this into the build-depends section in your .cabal"+  , "file and it should work (with the appropriate removal of commas)."+  , ""+  , "Note that version bounds are a statement that you've successfully built and"+  , "tested your package and expect it to work with any of the specified package"+  , "versions (PROVIDED that those packages continue to conform with the PVP)."+  , "Therefore, the version bounds generated here are the most conservative"+  , "based on the versions that you are currently building with.  If you know"+  , "your package will work with versions outside the ranges generated here,"+  , "feel free to widen them."+  , ""+  ]
+ src/Distribution/Client/Get.hs view
@@ -0,0 +1,333 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Get+-- Copyright   :  (c) Andrea Vezzosi 2008+--                    Duncan Coutts 2011+--                    John Millikin 2012+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'cabal get' command.+-----------------------------------------------------------------------------++module Distribution.Client.Get (+    get,++    -- * Cloning 'SourceRepo's+    -- | Mainly exported for testing purposes+    clonePackagesFromSourceRepo,+    ClonePackageException(..),+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)+import Distribution.Compat.Directory+         ( listDirectory )+import Distribution.Package+         ( PackageId, packageId, packageName )+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import Distribution.Simple.Utils+         ( notice, die', info, writeFileAtomic )+import qualified Distribution.PackageDescription as PD+import Distribution.Simple.Program+         ( programName )+import Distribution.Types.SourceRepo (RepoKind (..))+import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)++import Distribution.Client.Setup+         ( GlobalFlags(..), GetFlags(..), RepoContext(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.VCS+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)+import Distribution.Client.IndexUtils+        ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos )+import Distribution.Solver.Types.SourcePackage++import qualified Data.Map as Map+import System.Directory+         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )+import System.FilePath+         ( (</>), (<.>), addTrailingPathSeparator )+++-- | Entry point for the 'cabal get' command.+get :: Verbosity+    -> RepoContext+    -> GlobalFlags+    -> GetFlags+    -> [UserTarget]+    -> IO ()+get verbosity _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++get verbosity repoCtxt globalFlags getFlags userTargets = do+  let useSourceRepo = case getSourceRepository getFlags of+                        NoFlag -> False+                        _      -> True++  unless useSourceRepo $+    traverse_ (checkTarget verbosity) userTargets++  let idxState :: Maybe TotalIndexState+      idxState = flagToMaybe $ getIndexState getFlags++      activeRepos :: Maybe ActiveRepos+      activeRepos = flagToMaybe $ getActiveRepos getFlags++  (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos++  pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                   (fromFlag $ globalWorldFile globalFlags)+                   (packageIndex sourcePkgDb)+                   userTargets++  pkgs <- either (die' verbosity . unlines . map show) return $+            resolveWithoutDependencies+              (resolverParams sourcePkgDb pkgSpecifiers)++  unless (null prefix) $+    createDirectoryIfMissing True prefix++  if useSourceRepo+    then clone  pkgs+    else unpack pkgs++  where+    resolverParams sourcePkgDb pkgSpecifiers =+        --TODO: add command-line constraint and preference args for unpack+        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers++    prefix = fromFlagOrDefault "" (getDestDir getFlags)++    clone :: [UnresolvedSourcePackage] -> IO ()+    clone = clonePackagesFromSourceRepo verbosity prefix kind+          . map (\pkg -> (packageId pkg, packageSourceRepos pkg))+      where+        kind = fromFlag . getSourceRepository $ getFlags+        packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]+        packageSourceRepos = PD.sourceRepos+                           . PD.packageDescription+                           . srcpkgDescription++    unpack :: [UnresolvedSourcePackage] -> IO ()+    unpack pkgs = do+      for_ pkgs $ \pkg -> do+        location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg)+        let pkgid = packageId pkg+            descOverride | usePristine = Nothing+                         | otherwise   = srcpkgDescrOverride pkg+        case location of+          LocalTarballPackage tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RemoteTarballPackage _tarballURL tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RepoTarballPackage _repo _pkgid tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RemoteSourceRepoPackage _repo _ ->+            die' verbosity $ "The 'get' command does no yet support targets "+                          ++ "that are remote source repositories."++          LocalUnpackedPackage _ ->+            error "Distribution.Client.Get.unpack: the impossible happened."+      where+        usePristine = fromFlagOrDefault False (getPristine getFlags)++checkTarget :: Verbosity -> UserTarget -> IO ()+checkTarget verbosity target = case target of+    UserTargetLocalDir       dir  -> die' verbosity (notTarball dir)+    UserTargetLocalCabalFile file -> die' verbosity (notTarball file)+    _                             -> return ()+  where+    notTarball t =+        "The 'get' command is for tarball packages. "+     ++ "The target '" ++ t ++ "' is not a tarball."++-- ------------------------------------------------------------+-- * Unpacking the source tarball+-- ------------------------------------------------------------++unpackPackage :: Verbosity -> FilePath -> PackageId+              -> PackageDescriptionOverride+              -> FilePath  -> IO ()+unpackPackage verbosity prefix pkgid descOverride pkgPath = do+    let pkgdirname               = prettyShow pkgid+        pkgdir                   = prefix </> pkgdirname+        pkgdir'                  = addTrailingPathSeparator pkgdir+        emptyDirectory directory = null <$> listDirectory directory+    existsDir  <- doesDirectoryExist pkgdir+    when existsDir $ do+      isEmpty <- emptyDirectory pkgdir+      unless isEmpty $+        die' verbosity $+        "The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking."+    existsFile  <- doesFileExist pkgdir+    when existsFile $ die' verbosity $+     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."+    notice verbosity $ "Unpacking to " ++ pkgdir'+    Tar.extractTarGzFile prefix pkgdirname pkgPath++    case descOverride of+      Nothing     -> return ()+      Just pkgtxt -> do+        let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"+        info verbosity $+          "Updating " ++ descFilePath+                      ++ " with the latest revision from the index."+        writeFileAtomic descFilePath pkgtxt+++-- ------------------------------------------------------------+-- * Cloning packages from their declared source repositories+-- ------------------------------------------------------------+++data ClonePackageException =+       ClonePackageNoSourceRepos       PackageId+     | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)+     | ClonePackageNoRepoType          PackageId PD.SourceRepo+     | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType+     | ClonePackageNoRepoLocation      PackageId PD.SourceRepo+     | ClonePackageDestinationExists   PackageId FilePath Bool+     | ClonePackageFailedWithExitCode  PackageId SourceRepoProxy String ExitCode+  deriving (Show, Eq)++instance Exception ClonePackageException where+  displayException (ClonePackageNoSourceRepos pkgid) =+       "Cannot fetch a source repository for package " ++ prettyShow pkgid+    ++ ". The package does not specify any source repositories."++  displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =+       "Cannot fetch a source repository for package " ++ prettyShow pkgid+    ++ ". The package does not specify a source repository of the requested "+    ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind++  displayException (ClonePackageNoRepoType pkgid _repo) =+       "Cannot fetch the source repository for package " ++ prettyShow pkgid+    ++ ". The package's description specifies a source repository but does "+    ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."++  displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =+       "Cannot fetch the source repository for package " ++ prettyShow pkgid+    ++ ". The repository type '" ++ prettyShow repoType+    ++ "' is not yet supported."++  displayException (ClonePackageNoRepoLocation pkgid _repo) =+       "Cannot fetch the source repository for package " ++ prettyShow pkgid+    ++ ". The package's description specifies a source repository but does "+    ++ "not specify the repository 'location' field (i.e. the URL)."++  displayException (ClonePackageDestinationExists pkgid dest isdir) =+       "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "+    ++ if isdir then "The destination directory " ++ dest ++ " already exists."+                else "A file " ++ dest ++ " is in the way."++  displayException (ClonePackageFailedWithExitCode+                      pkgid repo vcsprogname exitcode) =+       "Failed to fetch the source repository for package " ++ prettyShow pkgid+    ++ ", repository location " ++ srpLocation repo ++ " ("+    ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."+++-- | Given a bunch of package ids and their corresponding available+-- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into+-- new subdirs of the given directory.+--+clonePackagesFromSourceRepo :: Verbosity+                            -> FilePath            -- ^ destination dir prefix+                            -> Maybe RepoKind      -- ^ preferred 'RepoKind'+                            -> [(PackageId, [PD.SourceRepo])]+                                                   -- ^ the packages and their+                                                   -- available 'SourceRepo's+                            -> IO ()+clonePackagesFromSourceRepo verbosity destDirPrefix+                            preferredRepoKind pkgrepos = do++    -- Do a bunch of checks and collect the required info+    pkgrepos' <- traverse preCloneChecks pkgrepos++    -- Configure the VCS drivers for all the repository types we may need+    vcss <- configureVCSs verbosity $+              Map.fromList [ (vcsRepoType vcs, vcs)+                           | (_, _, vcs, _) <- pkgrepos' ]++    -- Now execute all the required commands for each repo+    sequence_+      [ cloneSourceRepo verbosity vcs' repo destDir+          `catch` \exitcode ->+           throwIO (ClonePackageFailedWithExitCode+                      pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)+      | (pkgid, repo, vcs, destDir) <- pkgrepos'+      , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss+      ]++  where+    preCloneChecks :: (PackageId, [PD.SourceRepo])+                   -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)+    preCloneChecks (pkgid, repos) = do+      repo <- case selectPackageSourceRepo preferredRepoKind repos of+        Just repo            -> return repo+        Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)+        Nothing              -> throwIO (ClonePackageNoSourceReposOfKind+                                           pkgid preferredRepoKind)++      (repo', vcs) <- case validatePDSourceRepo repo of+        Right (repo', _, _, vcs) -> return (repo', vcs)+        Left SourceRepoRepoTypeUnspecified ->+          throwIO (ClonePackageNoRepoType pkgid repo)++        Left (SourceRepoRepoTypeUnsupported repo' repoType) ->+          throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)++        Left SourceRepoLocationUnspecified ->+          throwIO (ClonePackageNoRepoLocation pkgid repo)++      let destDir = destDirPrefix </> prettyShow (packageName pkgid)+      destDirExists  <- doesDirectoryExist destDir+      destFileExists <- doesFileExist      destDir+      when (destDirExists || destFileExists) $+        throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)++      return (pkgid, repo', vcs, destDir)++-------------------------------------------------------------------------------+-- Selecting+-------------------------------------------------------------------------------++-- | Pick the 'SourceRepo' to use to get the package sources from.+--+-- Note that this does /not/ depend on what 'VCS' drivers we are able to+-- successfully configure. It is based only on the 'SourceRepo's declared+-- in the package, and optionally on a preferred 'RepoKind'.+--+selectPackageSourceRepo :: Maybe RepoKind+                        -> [PD.SourceRepo]+                        -> Maybe PD.SourceRepo+selectPackageSourceRepo preferredRepoKind =+    listToMaybe+    -- Sort repositories by kind, from This to Head to Unknown. Repositories+    -- with equivalent kinds are selected based on the order they appear in+    -- the Cabal description file.+  . sortBy (comparing thisFirst)+    -- If the user has specified the repo kind, filter out the repositories+    -- they're not interested in.+  . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)+  where+    thisFirst :: PD.SourceRepo -> Int+    thisFirst r = case PD.repoKind r of+        RepoThis -> 0+        RepoHead -> case PD.repoTag r of+            -- If the type is 'head' but the author specified a tag, they+            -- probably meant to create a 'this' repository but screwed up.+            Just _  -> 0+            Nothing -> 1+        RepoKindUnknown _ -> 2
+ src/Distribution/Client/Glob.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE DeriveGeneric #-}++--TODO: [code cleanup] plausibly much of this module should be merged with+-- similar functionality in Cabal.+module Distribution.Client.Glob+    ( FilePathGlob(..)+    , FilePathRoot(..)+    , FilePathGlobRel(..)+    , Glob+    , GlobPiece(..)+    , matchFileGlob+    , matchFileGlobRel+    , matchGlob+    , isTrivialFilePathGlob+    , getFilePathRootDirectory+    ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Data.List        (stripPrefix)+import System.Directory+import System.FilePath++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp+++-- | A file path specified by globbing+--+data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel+  deriving (Eq, Show, Generic)++data FilePathGlobRel+   = GlobDir  !Glob !FilePathGlobRel+   | GlobFile !Glob+   | GlobDirTrailing                -- ^ trailing dir, a glob ending in @/@+  deriving (Eq, Show, Generic)++-- | A single directory or file component of a globbed path+type Glob = [GlobPiece]++-- | A piece of a globbing pattern+data GlobPiece = WildCard+               | Literal String+               | Union [Glob]+  deriving (Eq, Show, Generic)++data FilePathRoot+   = FilePathRelative+   | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'+   | FilePathHomeDir+  deriving (Eq, Show, Generic)++instance Binary FilePathGlob+instance Binary FilePathRoot+instance Binary FilePathGlobRel+instance Binary GlobPiece++instance Structured FilePathGlob+instance Structured FilePathRoot+instance Structured FilePathGlobRel+instance Structured GlobPiece++-- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and+-- is in fact equivalent to a non-glob 'FilePath'.+--+-- If it is trivial in this sense then the result is the equivalent constant+-- 'FilePath'. On the other hand if it is not trivial (so could in principle+-- match more than one file) then the result is @Nothing@.+--+isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath+isTrivialFilePathGlob (FilePathGlob root pathglob) =+    case root of+      FilePathRelative       -> go []      pathglob+      FilePathRoot root'     -> go [root'] pathglob+      FilePathHomeDir        -> Nothing+  where+    go paths (GlobDir  [Literal path] globs) = go (path:paths) globs+    go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))+    go paths  GlobDirTrailing          = Just (addTrailingPathSeparator+                                                 (joinPath (reverse paths)))+    go _ _ = Nothing++-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.+--+-- The 'FilePath' argument is required to supply the path for the+-- 'FilePathRelative' case.+--+getFilePathRootDirectory :: FilePathRoot+                         -> FilePath      -- ^ root for relative paths+                         -> IO FilePath+getFilePathRootDirectory  FilePathRelative   root = return root+getFilePathRootDirectory (FilePathRoot root) _    = return root+getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory+++------------------------------------------------------------------------------+-- Matching+--++-- | Match a 'FilePathGlob' against the file system, starting from a given+-- root directory for relative paths. The results of relative globs are+-- relative to the given root. Matches for absolute globs are absolute.+--+matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]+matchFileGlob relroot (FilePathGlob globroot glob) = do+    root <- getFilePathRootDirectory globroot relroot+    matches <- matchFileGlobRel root glob+    case globroot of+      FilePathRelative -> return matches+      _                -> return (map (root </>) matches)++-- | Match a 'FilePathGlobRel' against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]+matchFileGlobRel root glob0 = go glob0 ""+  where+    go (GlobFile glob) dir = do+      entries <- getDirectoryContents (root </> dir)+      let files = filter (matchGlob glob) entries+      return (map (dir </>) files)++    go (GlobDir glob globPath) dir = do+      entries <- getDirectoryContents (root </> dir)+      subdirs <- filterM (\subdir -> doesDirectoryExist+                                       (root </> dir </> subdir))+               $ filter (matchGlob glob) entries+      concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs++    go GlobDirTrailing dir = return [dir]+++-- | Match a globbing pattern against a file path component+--+matchGlob :: Glob -> String -> Bool+matchGlob = goStart+  where+    -- From the man page, glob(7):+    --   "If a filename starts with a '.', this character must be+    --    matched explicitly."++    go, goStart :: [GlobPiece] -> String -> Bool++    goStart (WildCard:_) ('.':_)  = False+    goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)+                                        globs+    goStart rest               cs = go rest cs++    go []                 ""    = True+    go (Literal lit:rest) cs+      | Just cs' <- stripPrefix lit cs+                                = go rest cs'+      | otherwise               = False+    go [WildCard]         ""    = True+    go (WildCard:rest)   (c:cs) = go rest (c:cs) || go (WildCard:rest) cs+    go (Union globs:rest)   cs  = any (\glob -> go (glob ++ rest) cs) globs+    go []                (_:_)  = False+    go (_:_)              ""    = False+++------------------------------------------------------------------------------+-- Parsing & printing+--++instance Pretty FilePathGlob where+  pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob++instance Parsec FilePathGlob where+    parsec = do+        root <- parsec+        case root of+            FilePathRelative -> FilePathGlob root <$> parsec+            _                -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)++instance Pretty FilePathRoot where+    pretty  FilePathRelative    = Disp.empty+    pretty (FilePathRoot root)  = Disp.text root+    pretty FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'++instance Parsec FilePathRoot where+    parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where+        root = FilePathRoot "/" <$ P.char '/'+        home = FilePathHomeDir <$ P.string "~/"+        drive = do+            dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+            _ <- P.char ':'+            _ <- P.char '/' <|> P.char '\\'+            return (FilePathRoot (toUpper dr : ":\\"))++instance Pretty FilePathGlobRel where+    pretty (GlobDir  glob pathglob) = dispGlob glob+                            Disp.<> Disp.char '/'+                            Disp.<> pretty pathglob+    pretty (GlobFile glob)          = dispGlob glob+    pretty GlobDirTrailing          = Disp.empty++instance Parsec FilePathGlobRel where+    parsec = parsecPath where+        parsecPath :: CabalParsing m => m FilePathGlobRel+        parsecPath = do+            glob <- parsecGlob+            dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)++        dirSep :: CabalParsing m => m ()+        dirSep = () <$ P.char '/' <|> P.try (do+            _ <- P.char '\\'+            -- check this isn't an escape code+            P.notFollowedBy (P.satisfy isGlobEscapedChar))++dispGlob :: Glob -> Disp.Doc+dispGlob = Disp.hcat . map dispPiece+  where+    dispPiece WildCard      = Disp.char '*'+    dispPiece (Literal str) = Disp.text (escape str)+    dispPiece (Union globs) = Disp.braces+                                (Disp.hcat (Disp.punctuate+                                             (Disp.char ',')+                                             (map dispGlob globs)))+    escape []               = []+    escape (c:cs)+      | isGlobEscapedChar c = '\\' : c : escape cs+      | otherwise           =        c : escape cs++parsecGlob :: CabalParsing m => m Glob+parsecGlob = some parsecPiece where+    parsecPiece = P.choice [ literal, wildcard, union ]++    wildcard = WildCard <$ P.char '*'+    union    = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))+    literal  = Literal <$> some litchar++    litchar = normal <|> escape++    normal  = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')+    escape  = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar++isGlobEscapedChar :: Char -> Bool+isGlobEscapedChar '*'  = True+isGlobEscapedChar '{'  = True+isGlobEscapedChar '}'  = True+isGlobEscapedChar ','  = True+isGlobEscapedChar _    = False
+ src/Distribution/Client/GlobalFlags.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++module Distribution.Client.GlobalFlags (+    GlobalFlags(..)+  , defaultGlobalFlags+  , RepoContext(..)+  , withRepoContext+  , withRepoContext'+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.Types+         ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey )+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, flagToMaybe )+import Distribution.Utils.NubList+         ( NubList, fromNubList )+import Distribution.Client.HttpUtils+         ( HttpTransport, configureTransport )+import Distribution.Simple.Utils+         ( info, warn )++import Distribution.Client.IndexUtils.ActiveRepos+         ( ActiveRepos )++import Control.Concurrent+         ( MVar, newMVar, modifyMVar )+import System.FilePath+         ( (</>) )+import Network.URI+         ( URI, uriScheme, uriPath )+import qualified Data.Map as Map++import qualified Hackage.Security.Client                    as Sec+import qualified Hackage.Security.Util.Path                 as Sec+import qualified Hackage.Security.Util.Pretty               as Sec+import qualified Hackage.Security.Client.Repository.Cache   as Sec+import qualified Hackage.Security.Client.Repository.Local   as Sec.Local+import qualified Hackage.Security.Client.Repository.Remote  as Sec.Remote+import qualified Distribution.Client.Security.HTTP          as Sec.HTTP+import qualified Distribution.Client.Security.DNS           as Sec.DNS++import qualified System.FilePath.Posix as FilePath.Posix++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- | Flags that apply at the top level, not to any sub-command.++data GlobalFlags = GlobalFlags+    { globalVersion           :: Flag Bool+    , globalNumericVersion    :: Flag Bool+    , globalConfigFile        :: Flag FilePath+    , globalConstraintsFile   :: Flag FilePath+    , globalRemoteRepos       :: NubList RemoteRepo     -- ^ Available Hackage servers.+    , globalCacheDir          :: Flag FilePath+    , globalLocalNoIndexRepos :: NubList LocalRepo+    , globalActiveRepos       :: Flag ActiveRepos+    , globalLogsDir           :: Flag FilePath+    , globalWorldFile         :: Flag FilePath+    , globalIgnoreExpiry      :: Flag Bool    -- ^ Ignore security expiry dates+    , globalHttpTransport     :: Flag String+    , globalNix               :: Flag Bool  -- ^ Integrate with Nix+    , globalStoreDir          :: Flag FilePath+    , globalProgPathExtra     :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)+    } deriving (Show, Generic)++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags+    { globalVersion           = Flag False+    , globalNumericVersion    = Flag False+    , globalConfigFile        = mempty+    , globalConstraintsFile   = mempty+    , globalRemoteRepos       = mempty+    , globalCacheDir          = mempty+    , globalLocalNoIndexRepos = mempty+    , globalActiveRepos       = mempty+    , globalLogsDir           = mempty+    , globalWorldFile         = mempty+    , globalIgnoreExpiry      = Flag False+    , globalHttpTransport     = mempty+    , globalNix               = Flag False+    , globalStoreDir          = mempty+    , globalProgPathExtra     = mempty+    }++instance Monoid GlobalFlags where+    mempty = gmempty+    mappend = (<>)++instance Semigroup GlobalFlags where+    (<>) = gmappend++-- ------------------------------------------------------------+-- * Repo context+-- ------------------------------------------------------------++-- | Access to repositories+data RepoContext = RepoContext {+    -- | All user-specified repositories+    repoContextRepos :: [Repo]++    -- | Get the HTTP transport+    --+    -- The transport will be initialized on the first call to this function.+    --+    -- NOTE: It is important that we don't eagerly initialize the transport.+    -- Initializing the transport is not free, and especially in contexts where+    -- we don't know a-priori whether or not we need the transport (for instance+    -- when using cabal in "nix mode") incurring the overhead of transport+    -- initialization on _every_ invocation (eg @cabal build@) is undesirable.+  , repoContextGetTransport :: IO HttpTransport++    -- | Get the (initialized) secure repo+    --+    -- (the 'Repo' type itself is stateless and must remain so, because it+    -- must be serializable)+  , repoContextWithSecureRepo :: forall a.+                                 Repo+                              -> (forall down. Sec.Repository down -> IO a)+                              -> IO a++    -- | Should we ignore expiry times (when checking security)?+  , repoContextIgnoreExpiry :: Bool+  }++-- | Wrapper around 'Repository', hiding the type argument+data SecureRepo = forall down. SecureRepo (Sec.Repository down)++withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a+withRepoContext verbosity globalFlags =+    withRepoContext'+      verbosity+      (fromNubList (globalRemoteRepos       globalFlags))+      (fromNubList (globalLocalNoIndexRepos globalFlags))+      (fromFlag    (globalCacheDir          globalFlags))+      (flagToMaybe (globalHttpTransport     globalFlags))+      (flagToMaybe (globalIgnoreExpiry      globalFlags))+      (fromNubList (globalProgPathExtra     globalFlags))++withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo]+                 -> FilePath  -> Maybe String -> Maybe Bool+                 -> [FilePath]+                 -> (RepoContext -> IO a)+                 -> IO a+withRepoContext' verbosity remoteRepos localNoIndexRepos+                 sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do+    for_ localNoIndexRepos $ \local ->+        unless (FilePath.Posix.isAbsolute (localRepoPath local)) $+            warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"++    transportRef <- newMVar Nothing+    let httpLib = Sec.HTTP.transportAdapter+                    verbosity+                    (getTransport transportRef)+    initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->+      callback RepoContext {+          repoContextRepos          = allRemoteRepos+                                   ++ allLocalNoIndexRepos+        , repoContextGetTransport   = getTransport transportRef+        , repoContextWithSecureRepo = withSecureRepo secureRepos'+        , repoContextIgnoreExpiry   = fromMaybe False ignoreExpiry+        }+  where+    secureRemoteRepos =+      [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ]++    allRemoteRepos :: [Repo]+    allRemoteRepos =+      [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir+      | remote <- remoteRepos+      , let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)+            isSecure = remoteRepoSecure remote == Just True+      ]++    allLocalNoIndexRepos :: [Repo]+    allLocalNoIndexRepos =+      [ RepoLocalNoIndex local cacheDir+      | local <- localNoIndexRepos+      , let cacheDir | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local+                     | otherwise                  = localRepoPath local+      ]++    getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport+    getTransport transportRef =+      modifyMVar transportRef $ \mTransport -> do+        transport <- case mTransport of+          Just tr -> return tr+          Nothing -> configureTransport verbosity extraPaths httpTransport+        return (Just transport, transport)++    withSecureRepo :: Map Repo SecureRepo+                   -> Repo+                   -> (forall down. Sec.Repository down -> IO a)+                   -> IO a+    withSecureRepo secureRepos repo callback =+      case Map.lookup repo secureRepos of+        Just (SecureRepo secureRepo) -> callback secureRepo+        Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"++-- | Initialize the provided secure repositories+--+-- Assumed invariant: `remoteRepoSecure` should be set for all these repos.+initSecureRepos :: forall a. Verbosity+                -> Sec.HTTP.HttpLib+                -> [(RemoteRepo, FilePath)]+                -> (Map Repo SecureRepo -> IO a)+                -> IO a+initSecureRepos verbosity httpLib repos callback = go Map.empty repos+  where+    go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a+    go !acc [] = callback acc+    go !acc ((r,cacheDir):rs) = do+      cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir+      initSecureRepo verbosity httpLib r cachePath $ \r' ->+        go (Map.insert (RepoSecure r cacheDir) r' acc) rs++-- | Initialize the given secure repo+--+-- The security library has its own concept of a "local" repository, distinct+-- from @cabal-install@'s; these are secure repositories, but live in the local+-- file system. We use the convention that these repositories are identified by+-- URLs of the form @file:/path/to/local/repo@.+initSecureRepo :: Verbosity+               -> Sec.HTTP.HttpLib+               -> RemoteRepo  -- ^ Secure repo ('remoteRepoSecure' assumed)+               -> Sec.Path Sec.Absolute -- ^ Cache dir+               -> (SecureRepo -> IO a)  -- ^ Callback+               -> IO a+initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do+    requiresBootstrap <- withRepo [] Sec.requiresBootstrap++    mirrors <- if requiresBootstrap+               then do+                   info verbosity $ "Trying to locate mirrors via DNS for " +++                                    "initial bootstrap of secure " +++                                    "repository '" ++ show remoteRepoURI +++                                    "' ..."++                   Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI+               else pure []++    withRepo mirrors $ \r -> do+      when requiresBootstrap $ Sec.uncheckClientErrors $+        Sec.bootstrap r+          (map Sec.KeyId    remoteRepoRootKeys)+          (Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))+      callback $ SecureRepo r+  where+    -- Initialize local or remote repo depending on the URI+    withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a+    withRepo _ callback | uriScheme remoteRepoURI == "file:" = do+      dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)+      Sec.Local.withRepository dir+                               cache+                               Sec.hackageRepoLayout+                               Sec.hackageIndexLayout+                               logTUF+                               callback+    withRepo mirrors callback =+      Sec.Remote.withRepository httpLib+                                (remoteRepoURI:mirrors)+                                Sec.Remote.defaultRepoOpts+                                cache+                                Sec.hackageRepoLayout+                                Sec.hackageIndexLayout+                                logTUF+                                callback++    cache :: Sec.Cache+    cache = Sec.Cache {+        cacheRoot   = cachePath+      , cacheLayout = Sec.cabalCacheLayout {+            Sec.cacheLayoutIndexTar   = cacheFn "01-index.tar"+          , Sec.cacheLayoutIndexIdx   = cacheFn "01-index.tar.idx"+          , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz"+          }+      }++    cacheFn :: FilePath -> Sec.CachePath+    cacheFn = Sec.rootPath . Sec.fragment++    -- We display any TUF progress only in verbose mode, including any transient+    -- verification errors. If verification fails, then the final exception that+    -- is thrown will of course be shown.+    logTUF :: Sec.LogMessage -> IO ()+    logTUF = info verbosity . Sec.pretty
+ src/Distribution/Client/Haddock.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Haddock+-- Copyright   :  (c) Andrea Vezzosi 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Interfacing with Haddock+--+-----------------------------------------------------------------------------+module Distribution.Client.Haddock+    (+     regenerateHaddockIndex+    )+    where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Data.List (maximumBy)+import System.Directory (createDirectoryIfMissing, renameFile)+import System.FilePath ((</>), splitFileName)+import Distribution.Package+         ( packageVersion )+import Distribution.Simple.Haddock (haddockPackagePaths)+import Distribution.Simple.Program (haddockProgram, ProgramDb+                                   , runProgram, requireProgramVersion)+import Distribution.Version (mkVersion, orLaterVersion)+import Distribution.Simple.PackageIndex+         ( InstalledPackageIndex, allPackagesByName )+import Distribution.Simple.Utils+         ( debug, installDirectoryContents, withTempDirectory )+import Distribution.InstalledPackageInfo as InstalledPackageInfo+         ( InstalledPackageInfo(exposed) )++regenerateHaddockIndex :: Verbosity+                       -> InstalledPackageIndex -> ProgramDb+                       -> FilePath+                       -> IO ()+regenerateHaddockIndex verbosity pkgs progdb index = do+      (paths, warns) <- haddockPackagePaths pkgs' Nothing+      let paths' = [ (interface, html) | (interface, Just html, _) <- paths]+      for_ warns (debug verbosity)++      (confHaddock, _, _) <-+          requireProgramVersion verbosity haddockProgram+                                    (orLaterVersion (mkVersion [0,6])) progdb++      createDirectoryIfMissing True destDir++      withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do++        let flags = [ "--gen-contents"+                    , "--gen-index"+                    , "--odir=" ++ tempDir+                    , "--title=Haskell modules on this system" ]+                 ++ [ "--read-interface=" ++ html ++ "," ++ interface+                    | (interface, html) <- paths' ]+        runProgram verbosity confHaddock flags+        renameFile (tempDir </> "index.html") (tempDir </> destFile)+        installDirectoryContents verbosity tempDir destDir++  where+    (destDir,destFile) = splitFileName index+    pkgs' = [ maximumBy (comparing packageVersion) pkgvers'+            | (_pname, pkgvers) <- allPackagesByName pkgs+            , let pkgvers' = filter exposed pkgvers+            , not (null pkgvers') ]
+ src/Distribution/Client/HashValue.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+module Distribution.Client.HashValue (+    HashValue,+    hashValue,+    truncateHash,+    showHashValue,+    readFileHashValue,+    hashFromTUF,+    ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Hackage.Security.Client as Sec++import qualified Crypto.Hash.SHA256         as SHA256+import qualified Data.ByteString.Base16     as Base16+import qualified Data.ByteString.Char8      as BS+import qualified Data.ByteString.Lazy.Char8 as LBS++import System.IO         (IOMode (..), withBinaryFile)++-----------------------------------------------+-- The specific choice of hash implementation+--++-- Is a crypto hash necessary here? One thing to consider is who controls the+-- inputs and what's the result of a hash collision. Obviously we should not+-- install packages we don't trust because they can run all sorts of code, but+-- if I've checked there's no TH, no custom Setup etc, is there still a+-- problem? If someone provided us a tarball that hashed to the same value as+-- some other package and we installed it, we could end up re-using that+-- installed package in place of another one we wanted. So yes, in general+-- there is some value in preventing intentional hash collisions in installed+-- package ids.++newtype HashValue = HashValue BS.ByteString+  deriving (Eq, Generic, Show, Typeable)++-- Cannot do any sensible validation here. Although we use SHA256+-- for stuff we hash ourselves, we can also get hashes from TUF+-- and that can in principle use different hash functions in future.+--+-- Therefore, we simply derive this structurally.+instance Binary HashValue+instance Structured HashValue++-- | Hash some data. Currently uses SHA256.+--+hashValue :: LBS.ByteString -> HashValue+hashValue = HashValue . SHA256.hashlazy++showHashValue :: HashValue -> String+showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)++-- | Hash the content of a file. Uses SHA256.+--+readFileHashValue :: FilePath -> IO HashValue+readFileHashValue tarball =+    withBinaryFile tarball ReadMode $ \hnd ->+      evaluate . hashValue =<< LBS.hGetContents hnd++-- | Convert a hash from TUF metadata into a 'PackageSourceHash'.+--+-- Note that TUF hashes don't neessarily have to be SHA256, since it can+-- support new algorithms in future.+--+hashFromTUF :: Sec.Hash -> HashValue+hashFromTUF (Sec.Hash hashstr) =+    --TODO: [code cleanup] either we should get TUF to use raw bytestrings or+    -- perhaps we should also just use a base16 string as the internal rep.+    case Base16.decode (BS.pack hashstr) of+#if MIN_VERSION_base16_bytestring(1,0,0)+      Right hash -> HashValue hash+      Left _ -> error "hashFromTUF: cannot decode base16"+#else+      (hash, trailing) | not (BS.null hash) && BS.null trailing+        -> HashValue hash+      _ -> error "hashFromTUF: cannot decode base16 hash"+#endif++-- | Truncate a 32 byte SHA256 hash to+--+-- For example 20 bytes render as 40 hex chars, which we use for unit-ids.+-- Or even 4 bytes for 'hashedInstalledPackageIdShort'+--+truncateHash :: Int -> HashValue -> HashValue+truncateHash n (HashValue h) = HashValue (BS.take n h)
+ src/Distribution/Client/HttpUtils.hs view
@@ -0,0 +1,916 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP          #-}+-----------------------------------------------------------------------------+-- | Separate module for HTTP actions, using a proxy server if one exists.+-----------------------------------------------------------------------------+module Distribution.Client.HttpUtils (+    DownloadResult(..),+    configureTransport,+    HttpTransport(..),+    HttpCode,+    downloadURI,+    transportCheckHttps,+    remoteRepoCheckHttps,+    remoteRepoTryUpgradeToHttps,+    isOldHackageURI+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (Proxy (..))+import Distribution.Utils.Generic++import Network.HTTP+         ( Request (..), Response (..), RequestMethod (..)+         , Header(..), HeaderName(..), lookupHeader )+import Network.HTTP.Proxy ( Proxy(..), fetchProxy)+import Network.URI+         ( URI (..), URIAuth (..), uriToString )+import Network.Browser+         ( browse, setOutHandler, setErrHandler, setProxy+         , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )+import qualified Control.Exception as Exception+import Distribution.Simple.Utils+         ( die', info, warn, debug, notice+         , copyFileVerbose,  withTempFile, IOData (..) )+import Distribution.Client.Utils+         ( withTempFileName, cabalInstallVersion )+import Distribution.Client.Types+         ( unRepoName, RemoteRepo(..) )+import Distribution.System+         ( buildOS, buildArch )+import qualified System.FilePath.Posix as FilePath.Posix+         ( splitDirectories )+import System.FilePath+         ( (<.>), takeFileName, takeDirectory )+import System.Directory+         ( doesFileExist, renameFile, canonicalizePath )+import System.IO+         ( withFile, IOMode(ReadMode), hGetContents, hClose )+import System.IO.Error+         ( isDoesNotExistError )+import Distribution.Simple.Program+         ( Program, simpleProgram, ConfiguredProgram, programPath+         , ProgramInvocation(..), programInvocation+         , ProgramSearchPathEntry(..)+         , getProgramInvocationOutput )+import Distribution.Simple.Program.Db+         ( ProgramDb, emptyProgramDb, addKnownPrograms+         , configureAllKnownPrograms+         , requireProgram, lookupProgram+         , modifyProgramSearchPath )+import Distribution.Simple.Program.Run+         ( getProgramInvocationOutputAndErrors )+import Numeric (showHex)+import System.Random (randomRIO)++import qualified Crypto.Hash.SHA256         as SHA256+import qualified Data.ByteString.Base16     as Base16+import qualified Distribution.Compat.CharParsing as P+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Char8      as BS8+import qualified Data.ByteString.Lazy       as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS8++------------------------------------------------------------------------------+-- Downloading a URI, given an HttpTransport+--++data DownloadResult = FileAlreadyInCache+                    | FileDownloaded FilePath+  deriving (Eq)++data DownloadCheck+    = Downloaded                           -- ^ already downloaded and sha256 matches+    | CheckETag String                     -- ^ already downloaded and we have etag+    | NeedsDownload (Maybe BS.ByteString)  -- ^ needs download with optional hash check+  deriving Eq++downloadURI :: HttpTransport+            -> Verbosity+            -> URI      -- ^ What to download+            -> FilePath -- ^ Where to put it+            -> IO DownloadResult+downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do+  copyFileVerbose verbosity (uriPath uri) path+  return (FileDownloaded path)+  -- Can we store the hash of the file so we can safely return path when the+  -- hash matches to avoid unnecessary computation?++downloadURI transport verbosity uri path = do++    targetExists <- doesFileExist path++    downloadCheck <-+      -- if we have uriFrag, then we expect there to be #sha256=...+      if not (null uriFrag)+      then case sha256parsed of+        -- we know the hash, and target exists+        Right expected | targetExists -> do+          contents <- LBS.readFile path+          let actual = SHA256.hashlazy contents+          if expected == actual+          then return Downloaded+          else return (NeedsDownload (Just expected))++        -- we known the hash, target doesn't exist+        Right expected -> return (NeedsDownload (Just expected))++        -- we failed to parse uriFragment+        Left err -> die' verbosity $+          "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err++      -- if there are no uri fragment, use ETag+      else do+        etagPathExists <- doesFileExist etagPath+        -- In rare cases the target file doesn't exist, but the etag does.+        if targetExists && etagPathExists+        then return (CheckETag etagPath)+        else return (NeedsDownload Nothing)++    -- Only use the external http transports if we actually have to+    -- (or have been told to do so)+    let transport'+          | uriScheme uri == "http:"+          , not (transportManuallySelected transport)+          = plainHttpTransport++          | otherwise+          = transport++    case downloadCheck of+      Downloaded         -> return FileAlreadyInCache+      CheckETag etag     -> makeDownload transport' Nothing (Just etag)+      NeedsDownload hash -> makeDownload transport' hash Nothing++  where+    makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do+      result <- getHttp transport' verbosity uri etag tmpFile []++      -- Only write the etag if we get a 200 response code.+      -- A 304 still sends us an etag header.+      case result of+        -- if we have hash, we don't care about etag.+        (200, _) | Just expected <- sha256 -> do+          contents <- LBS.readFile tmpFile+          let actual = SHA256.hashlazy contents+          unless (actual == expected) $+            die' verbosity $ unwords+              [ "Failed to download", show uri+              , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected)+              , "actual:", BS8.unpack (Base16.encode actual)+              ]++        (200, Just newEtag) -> writeFile etagPath newEtag+        _ -> return ()++      case fst result of+        200 -> do+            info verbosity ("Downloaded to " ++ path)+            renameFile tmpFile path+            return (FileDownloaded path)+        304 -> do+            notice verbosity "Skipping download: local and remote files match."+            return FileAlreadyInCache+        errCode ->  die' verbosity $ "failed to download " ++ show uri+                       ++ " : HTTP code " ++ show errCode++    etagPath = path <.> "etag"+    uriFrag = uriFragment uri++    sha256parsed :: Either String BS.ByteString+    sha256parsed = explicitEitherParsec fragmentParser uriFrag++    fragmentParser = do+        _ <- P.string "#sha256="+        str <- some P.hexDigit+        let bs = Base16.decode (BS8.pack str)+#if MIN_VERSION_base16_bytestring(1,0,0)+        either fail return bs+#else+        return (fst bs)+#endif++------------------------------------------------------------------------------+-- Utilities for repo url management+--++remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()+remoteRepoCheckHttps verbosity transport repo+  | uriScheme (remoteRepoURI repo) == "https:"+  , not (transportSupportsHttps transport)+  = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)+    ++ "' specifies a URL that " ++ requiresHttpsErrorMessage+  | otherwise = return ()++transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()+transportCheckHttps verbosity transport uri+  | uriScheme uri == "https:"+  , not (transportSupportsHttps transport)+              = die' verbosity $ "The URL " ++ show uri+                   ++ " " ++ requiresHttpsErrorMessage+  | otherwise = return ()++requiresHttpsErrorMessage :: String+requiresHttpsErrorMessage =+      "requires HTTPS however the built-in HTTP implementation "+   ++ "does not support HTTPS. The transport implementations with HTTPS "+   ++ "support are " ++ intercalate ", "+      [ name | (name, _, True, _ ) <- supportedTransports ]+   ++ ". One of these will be selected automatically if the corresponding "+   ++ "external program is available, or one can be selected specifically "+   ++ "with the global flag --http-transport="++remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo+remoteRepoTryUpgradeToHttps verbosity transport repo+  | remoteRepoShouldTryHttps repo+  , uriScheme (remoteRepoURI repo) == "http:"+  , not (transportSupportsHttps transport)+  , not (transportManuallySelected transport)+  = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using "+       ++ "HTTPS for authenticated uploads is recommended. "+       ++ "The transport implementations with HTTPS support are "+       ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]+       ++ "but they require the corresponding external program to be "+       ++ "available. You can either make one available or use plain HTTP by "+       ++ "using the global flag --http-transport=plain-http (or putting the "+       ++ "equivalent in the config file). With plain HTTP, your password "+       ++ "is sent using HTTP digest authentication so it cannot be easily "+       ++ "intercepted, but it is not as secure as using HTTPS."++  | remoteRepoShouldTryHttps repo+  , uriScheme (remoteRepoURI repo) == "http:"+  , transportSupportsHttps transport+  = return repo {+      remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }+    }++  | otherwise+  = return repo++-- | Utility function for legacy support.+isOldHackageURI :: URI -> Bool+isOldHackageURI uri+    = case uriAuthority uri of+        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->+            FilePath.Posix.splitDirectories (uriPath uri)+            == ["/","packages","archive"]+        _ -> False+++------------------------------------------------------------------------------+-- Setting up a HttpTransport+--++data HttpTransport = HttpTransport {+      -- | GET a URI, with an optional ETag (to do a conditional fetch),+      -- write the resource to the given file and return the HTTP status code,+      -- and optional ETag.+      getHttp  :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]+               -> IO (HttpCode, Maybe ETag),++      -- | POST a resource to a URI, with optional auth (username, password)+      -- and return the HTTP status code and any redirect URL.+      postHttp :: Verbosity -> URI -> String -> Maybe Auth+               -> IO (HttpCode, String),++      -- | POST a file resource to a URI using multipart\/form-data encoding,+      -- with optional auth (username, password) and return the HTTP status+      -- code and any error string.+      postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth+                   -> IO (HttpCode, String),++      -- | PUT a file resource to a URI, with optional auth+      -- (username, password), extra headers and return the HTTP status code+      -- and any error string.+      putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]+                  -> IO (HttpCode, String),++      -- | Whether this transport supports https or just http.+      transportSupportsHttps :: Bool,++      -- | Whether this transport implementation was specifically chosen by+      -- the user via configuration, or whether it was automatically selected.+      -- Strictly speaking this is not a property of the transport itself but+      -- about how it was chosen. Nevertheless it's convenient to keep here.+      transportManuallySelected :: Bool+    }+    --TODO: why does postHttp return a redirect, but postHttpFile return errors?++type HttpCode = Int+type ETag     = String+type Auth     = (String, String)++noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)+          -> IO (Int, String)+noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet"++supportedTransports :: [(String, Maybe Program, Bool,+                         ProgramDb -> Maybe HttpTransport)]+supportedTransports =+    [ let prog = simpleProgram "curl" in+      ( "curl", Just prog, True+      , \db -> curlTransport <$> lookupProgram prog db )++    , let prog = simpleProgram "wget" in+      ( "wget", Just prog, True+      , \db -> wgetTransport <$> lookupProgram prog db )++    , let prog = simpleProgram "powershell" in+      ( "powershell", Just prog, True+      , \db -> powershellTransport <$> lookupProgram prog db )++    , ( "plain-http", Nothing, False+      , \_ -> Just plainHttpTransport )+    ]++configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport++configureTransport verbosity extraPath (Just name) =+    -- the user specifically selected a transport by name so we'll try and+    -- configure that one++    case find (\(name',_,_,_) -> name' == name) supportedTransports of+      Just (_, mprog, _tls, mkTrans) -> do++        let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb+        progdb <- case mprog of+          Nothing   -> return emptyProgramDb+          Just prog -> snd <$> requireProgram verbosity prog baseProgDb+                       --      ^^ if it fails, it'll fail here++        let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb+        return transport { transportManuallySelected = True }++      Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name+                    ++ ". The supported transports are "+                    ++ intercalate ", "+                         [ name' | (name', _, _, _ ) <- supportedTransports ]++configureTransport verbosity extraPath Nothing = do+    -- the user hasn't selected a transport, so we'll pick the first one we+    -- can configure successfully, provided that it supports tls++    -- for all the transports except plain-http we need to try and find+    -- their external executable+    let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb+    progdb <- configureAllKnownPrograms  verbosity $+                addKnownPrograms+                  [ prog | (_, Just prog, _, _) <- supportedTransports ]+                  baseProgDb++    let availableTransports =+          [ (name, transport)+          | (name, _, _, mkTrans) <- supportedTransports+          , transport <- maybeToList (mkTrans progdb) ]+    let (name, transport) =+         fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)+    debug verbosity $ "Selected http transport implementation: " ++ name++    return transport { transportManuallySelected = False }+++------------------------------------------------------------------------------+-- The HttpTransports based on external programs+--++curlTransport :: ConfiguredProgram -> HttpTransport+curlTransport prog =+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+        withTempFile (takeDirectory destPath)+                     "curl-headers.txt" $ \tmpFile tmpHandle -> do+          hClose tmpHandle+          let args = [ show uri+                   , "--output", destPath+                   , "--location"+                   , "--write-out", "%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--dump-header", tmpFile ]+                ++ concat+                   [ ["--header", "If-None-Match: " ++ t]+                   | t <- maybeToList etag ]+                ++ concat+                   [ ["--header", show name ++ ": " ++ value]+                   | Header name value <- reqHeaders ]++          resp <- getProgramInvocationOutput verbosity+                    (programInvocation prog args)+          withFile tmpFile ReadMode $ \hnd -> do+            headers <- hGetContents hnd+            (code, _err, etag') <- parseResponse verbosity uri resp headers+            evaluate $ force (code, etag')++    posthttp = noPostYet++    addAuthConfig auth progInvocation = progInvocation+      { progInvokeInput = do+          (uname, passwd) <- auth+          return $ IODataText $ unlines+            [ "--digest"+            , "--user " ++ uname ++ ":" ++ passwd+            ]+      , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation+      }++    posthttpfile verbosity uri path auth = do+        let args = [ show uri+                   , "--form", "package=@"++path+                   , "--write-out", "\n%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--header", "Accept: text/plain"+                   , "--location"+                   ]+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+                  (programInvocation prog args)+        (code, err, _etag) <- parseResponse verbosity uri resp ""+        return (code, err)++    puthttpfile verbosity uri path auth headers = do+        let args = [ show uri+                   , "--request", "PUT", "--data-binary", "@"++path+                   , "--write-out", "\n%{http_code}"+                   , "--user-agent", userAgent+                   , "--silent", "--show-error"+                   , "--location"+                   , "--header", "Accept: text/plain"+                   ]+                ++ concat+                   [ ["--header", show name ++ ": " ++ value]+                   | Header name value <- headers ]+        resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth+                  (programInvocation prog args)+        (code, err, _etag) <- parseResponse verbosity uri resp ""+        return (code, err)++    -- on success these curl invocations produces an output like "200"+    -- and on failure it has the server error response first+    parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag)+    parseResponse verbosity uri resp headers =+      let codeerr =+            case reverse (lines resp) of+              (codeLine:rerrLines) ->+                case readMaybe (trim codeLine) of+                  Just i  -> let errstr = mkErrstr rerrLines+                              in Just (i, errstr)+                  Nothing -> Nothing+              []          -> Nothing++          mkErrstr = unlines . reverse . dropWhile (all isSpace)++          mb_etag :: Maybe ETag+          mb_etag  = listToMaybe $ reverse+                     [ etag+                     | ["ETag:", etag] <- map words (lines headers) ]++       in case codeerr of+            Just (i, err) -> return (i, err, mb_etag)+            _             -> statusParseFail verbosity uri resp+++wgetTransport :: ConfiguredProgram -> HttpTransport+wgetTransport prog =+  HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  where+    gethttp verbosity uri etag destPath reqHeaders =  do+        resp <- runWGet verbosity uri args++        -- wget doesn't support range requests.+        -- so, we not only ignore range request headers,+        -- but we also dispay a warning message when we see them.+        let hasRangeHeader =  any isRangeHeader reqHeaders+            warningMsg     =  "the 'wget' transport currently doesn't support"+                           ++ " range requests, which wastes network bandwidth."+                           ++ " To fix this, set 'http-transport' to 'curl' or"+                           ++ " 'plain-http' in '~/.cabal/config'."+                           ++ " Note that the 'plain-http' transport doesn't"+                           ++ " support HTTPS.\n"++        when (hasRangeHeader) $ warn verbosity warningMsg+        (code, etag') <- parseOutput verbosity uri resp+        return (code, etag')+      where+        args = [ "--output-document=" ++ destPath+               , "--user-agent=" ++ userAgent+               , "--tries=5"+               , "--timeout=15"+               , "--server-response" ]+            ++ concat+               [ ["--header", "If-None-Match: " ++ t]+               | t <- maybeToList etag ]+            ++ [ "--header=" ++ show name ++ ": " ++ value+               | hdr@(Header name value) <- reqHeaders+               , (not (isRangeHeader hdr)) ]++        -- wget doesn't support range requests.+        -- so, we ignore range request headers, lest we get errors.+        isRangeHeader :: Header -> Bool+        isRangeHeader (Header HdrRange _) = True+        isRangeHeader _ = False++    posthttp = noPostYet++    posthttpfile verbosity  uri path auth =+        withTempFile (takeDirectory path)+                     (takeFileName path) $ \tmpFile tmpHandle ->+        withTempFile (takeDirectory path) "response" $+        \responseFile responseHandle -> do+          hClose responseHandle+          (body, boundary) <- generateMultipartBody path+          LBS.hPut tmpHandle body+          hClose tmpHandle+          let args = [ "--post-file=" ++ tmpFile+                     , "--user-agent=" ++ userAgent+                     , "--server-response"+                     , "--output-document=" ++ responseFile+                     , "--header=Accept: text/plain"+                     , "--header=Content-type: multipart/form-data; " +++                                              "boundary=" ++ boundary ]+          out <- runWGet verbosity (addUriAuth auth uri) args+          (code, _etag) <- parseOutput verbosity uri out+          withFile responseFile ReadMode $ \hnd -> do+            resp <- hGetContents hnd+            evaluate $ force (code, resp)++    puthttpfile verbosity uri path auth headers =+        withTempFile (takeDirectory path) "response" $+        \responseFile responseHandle -> do+            hClose responseHandle+            let args = [ "--method=PUT", "--body-file="++path+                       , "--user-agent=" ++ userAgent+                       , "--server-response"+                       , "--output-document=" ++ responseFile+                       , "--header=Accept: text/plain" ]+                    ++ [ "--header=" ++ show name ++ ": " ++ value+                       | Header name value <- headers ]++            out <- runWGet verbosity (addUriAuth auth uri) args+            (code, _etag) <- parseOutput verbosity uri out+            withFile responseFile ReadMode $ \hnd -> do+              resp <- hGetContents hnd+              evaluate $ force (code, resp)++    addUriAuth Nothing uri = uri+    addUriAuth (Just (user, pass)) uri = uri+      { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }+      }+     where+      a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)++    runWGet verbosity uri args = do+        -- We pass the URI via STDIN because it contains the users' credentials+        -- and sensitive data should not be passed via command line arguments.+        let+          invocation = (programInvocation prog ("--input-file=-" : args))+            { progInvokeInput = Just $ IODataText $ uriToString id uri ""+            }++        -- wget returns its output on stderr rather than stdout+        (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity+                                 invocation+        -- wget returns exit code 8 for server "errors" like "304 not modified"+        if exitCode == ExitSuccess || exitCode == ExitFailure 8+          then return resp+          else die' verbosity $ "'" ++ programPath prog+                  ++ "' exited with an error:\n" ++ resp++    -- With the --server-response flag, wget produces output with the full+    -- http server response with all headers, we want to find a line like+    -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple+    -- requests due to redirects.+    parseOutput verbosity uri resp =+      let parsedCode = listToMaybe+                     [ code+                     | (protocol:codestr:_err) <- map words (reverse (lines resp))+                     , "HTTP/" `isPrefixOf` protocol+                     , code <- maybeToList (readMaybe codestr) ]+          mb_etag :: Maybe ETag+          mb_etag  = listToMaybe+                    [ etag+                    | ["ETag:", etag] <- map words (reverse (lines resp)) ]+       in case parsedCode of+            Just i -> return (i, mb_etag)+            _      -> statusParseFail verbosity uri resp+++powershellTransport :: ConfiguredProgram -> HttpTransport+powershellTransport prog =+    HttpTransport gethttp posthttp posthttpfile puthttpfile True False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+      resp <- runPowershellScript verbosity $+        webclientScript+          (escape (show uri))+          (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")+          :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))+          [ "$response = $request.GetResponse()"+          , "$responseStream = $response.GetResponseStream()"+          , "$buffer = new-object byte[] 10KB"+          , "$count = $responseStream.Read($buffer, 0, $buffer.length)"+          , "while ($count -gt 0)"+          , "{"+          , "    $targetStream.Write($buffer, 0, $count)"+          , "    $count = $responseStream.Read($buffer, 0, $buffer.length)"+          , "}"+          , "Write-Host ($response.StatusCode -as [int]);"+          , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"+          ]+          [ "$targetStream.Flush()"+          , "$targetStream.Close()"+          , "$targetStream.Dispose()"+          , "$responseStream.Dispose()"+          ]+      parseResponse resp+      where+        parseResponse :: String -> IO (HttpCode, Maybe ETag)+        parseResponse x =+          case lines $ trim x of+            (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x+            (code:      _) -> fmap (\c -> (c, Nothing  )) $ parseCode code x+            _              -> statusParseFail verbosity uri x+        parseCode :: String -> String -> IO HttpCode+        parseCode code x = case readMaybe code of+          Just i  -> return i+          Nothing -> statusParseFail verbosity uri x+        etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]++    posthttp = noPostYet++    posthttpfile verbosity uri path auth =+      withTempFile (takeDirectory path)+                   (takeFileName path) $ \tmpFile tmpHandle -> do+        (body, boundary) <- generateMultipartBody path+        LBS.hPut tmpHandle body+        hClose tmpHandle+        fullPath <- canonicalizePath tmpFile++        let contentHeader = Header HdrContentType+              ("multipart/form-data; boundary=" ++ boundary)+        resp <- runPowershellScript verbosity $ webclientScript+          (escape (show uri))+          (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)+          (uploadFileAction "POST" uri fullPath)+          uploadFileCleanup+        parseUploadResponse verbosity uri resp++    puthttpfile verbosity uri path auth headers = do+      fullPath <- canonicalizePath path+      resp <- runPowershellScript verbosity $ webclientScript+        (escape (show uri))+        (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)+        (uploadFileAction "PUT" uri fullPath)+        uploadFileCleanup+      parseUploadResponse verbosity uri resp++    runPowershellScript verbosity script = do+      let args =+            [ "-InputFormat", "None"+            -- the default execution policy doesn't allow running+            -- unsigned scripts, so we need to tell powershell to bypass it+            , "-ExecutionPolicy", "bypass"+            , "-NoProfile", "-NonInteractive"+            , "-Command", "-"+            ]+      debug verbosity script+      getProgramInvocationOutput verbosity (programInvocation prog args)+        { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"+        }++    escape = show++    useragentHeader = Header HdrUserAgent userAgent+    extraHeaders = [Header HdrAccept "text/plain", useragentHeader]++    setupHeaders headers =+      [ "$request." ++ addHeader name value+      | Header name value <- headers+      ]+      where+        addHeader header value+          = case header of+              HdrAccept           -> "Accept = "           ++ escape value+              HdrUserAgent        -> "UserAgent = "        ++ escape value+              HdrConnection       -> "Connection = "       ++ escape value+              HdrContentLength    -> "ContentLength = "    ++ escape value+              HdrContentType      -> "ContentType = "      ++ escape value+              HdrDate             -> "Date = "             ++ escape value+              HdrExpect           -> "Expect = "           ++ escape value+              HdrHost             -> "Host = "             ++ escape value+              HdrIfModifiedSince  -> "IfModifiedSince = "  ++ escape value+              HdrReferer          -> "Referer = "          ++ escape value+              HdrTransferEncoding -> "TransferEncoding = " ++ escape value+              HdrRange            -> let (start, end) =+                                          if "bytes=" `isPrefixOf` value+                                             then case break (== '-') value' of+                                                 (start', '-':end') -> (start', end')+                                                 _                  -> error $ "Could not decode range: " ++ value+                                             else error $ "Could not decode range: " ++ value+                                         value' = drop 6 value+                                     in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"+              name                -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"++    setupAuth auth =+      [ "$request.Credentials = new-object System.Net.NetworkCredential("+          ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"+      | (uname,passwd) <- maybeToList auth+      ]++    uploadFileAction method _uri fullPath =+      [ "$request.Method = " ++ show method+      , "$requestStream = $request.GetRequestStream()"+      , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")"+      , "$bufSize=10000"+      , "$chunk = New-Object byte[] $bufSize"+      , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )"+      , "{"+      , "  $requestStream.write($chunk, 0, $bytesRead)"+      , "  $requestStream.Flush()"+      , "}"+      , ""+      , "$responseStream = $request.getresponse()"+      , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()"+      , "$code = $response.StatusCode -as [int]"+      , "if ($code -eq 0) {"+      , "  $code = 200;"+      , "}"+      , "Write-Host $code"+      , "Write-Host $responseReader.ReadToEnd()"+      ]++    uploadFileCleanup =+      [ "$fileStream.Close()"+      , "$requestStream.Close()"+      , "$responseStream.Close()"+      ]++    parseUploadResponse verbosity uri resp = case lines (trim resp) of+      (codeStr : message)+        | Just code <- readMaybe codeStr -> return (code, unlines message)+      _ -> statusParseFail verbosity uri resp++    webclientScript uri setup action cleanup = unlines+      [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""+      , "$uri = New-Object \"System.Uri\" " ++ uri+      , "$request = [System.Net.HttpWebRequest]::Create($uri)"+      , unlines setup+      , "Try {"+      , unlines (map ("  " ++) action)+      , "} Catch [System.Net.WebException] {"+      , "  $exception = $_.Exception;"+      , "  If ($exception.Status -eq "+        ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"+      , "    $response = $exception.Response -as [System.Net.HttpWebResponse];"+      , "    $reader = new-object "+        ++ "System.IO.StreamReader($response.GetResponseStream());"+      , "    Write-Host ($response.StatusCode -as [int]);"+      , "    Write-Host $reader.ReadToEnd();"+      , "  } Else {"+      , "    Write-Host $exception.Message;"+      , "  }"+      , "} Catch {"+      , "  Write-Host $_.Exception.Message;"+      , "} finally {"+      , unlines (map ("  " ++) cleanup)+      , "}"+      ]+++------------------------------------------------------------------------------+-- The builtin plain HttpTransport+--++plainHttpTransport :: HttpTransport+plainHttpTransport =+    HttpTransport gethttp posthttp posthttpfile puthttpfile False False+  where+    gethttp verbosity uri etag destPath reqHeaders = do+      let req = Request{+                  rqURI     = uri,+                  rqMethod  = GET,+                  rqHeaders = [ Header HdrIfNoneMatch t+                              | t <- maybeToList etag ]+                           ++ reqHeaders,+                  rqBody    = LBS.empty+                }+      (_, resp) <- cabalBrowse verbosity Nothing (request req)+      let code  = convertRspCode (rspCode resp)+          etag' = lookupHeader HdrETag (rspHeaders resp)+      -- 206 Partial Content is a normal response to a range request; see #3385.+      when (code==200 || code==206) $+        writeFileAtomic destPath $ rspBody resp+      return (code, etag')++    posthttp = noPostYet++    posthttpfile verbosity uri path auth = do+      (body, boundary) <- generateMultipartBody path+      let headers = [ Header HdrContentType+                             ("multipart/form-data; boundary="++boundary)+                    , Header HdrContentLength (show (LBS8.length body))+                    , Header HdrAccept ("text/plain")+                    ]+          req = Request {+                  rqURI     = uri,+                  rqMethod  = POST,+                  rqHeaders = headers,+                  rqBody    = body+                }+      (_, resp) <- cabalBrowse verbosity auth (request req)+      return (convertRspCode (rspCode resp), rspErrorString resp)++    puthttpfile verbosity uri path auth headers = do+      body <- LBS8.readFile path+      let req = Request {+                  rqURI     = uri,+                  rqMethod  = PUT,+                  rqHeaders = Header HdrContentLength (show (LBS8.length body))+                            : Header HdrAccept "text/plain"+                            : headers,+                  rqBody    = body+                }+      (_, resp) <- cabalBrowse verbosity auth (request req)+      return (convertRspCode (rspCode resp), rspErrorString resp)++    convertRspCode (a,b,c) = a*100 + b*10 + c++    rspErrorString resp =+      case lookupHeader HdrContentType (rspHeaders resp) of+        Just contenttype+           | takeWhile (/= ';') contenttype == "text/plain"+          -> LBS8.unpack (rspBody resp)+        _ -> rspReason resp++    cabalBrowse verbosity auth act = do+      p <- fixupEmptyProxy <$> fetchProxy True+      Exception.handleJust+        (guard . isDoesNotExistError)+        (const . die' verbosity $ "Couldn't establish HTTP connection. "+                    ++ "Possible cause: HTTP proxy server is down.") $+        browse $ do+          setProxy p+          setErrHandler (warn verbosity . ("http error: "++))+          setOutHandler (debug verbosity)+          setUserAgent  userAgent+          setAllowBasicAuth False+          setAuthorityGen (\_ _ -> return auth)+          act++    fixupEmptyProxy (Proxy uri _) | null uri = NoProxy+    fixupEmptyProxy p = p+++------------------------------------------------------------------------------+-- Common stuff used by multiple transport impls+--++userAgent :: String+userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion+                   , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")"+                   ]++statusParseFail :: Verbosity -> URI -> String -> IO a+statusParseFail verbosity uri r =+    die' verbosity $ "Failed to download " ++ show uri ++ " : "+       ++ "No Status Code could be parsed from response: " ++ r++-- Trim+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace+++------------------------------------------------------------------------------+-- Multipart stuff partially taken from cgi package.+--++generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)+generateMultipartBody path = do+    content  <- LBS.readFile path+    boundary <- genBoundary+    let !body = formatBody content (LBS8.pack boundary)+    return (body, boundary)+  where+    formatBody content boundary =+        LBS8.concat $+        [ crlf, dd, boundary, crlf ]+     ++ [ LBS8.pack (show header) | header <- headers ]+     ++ [ crlf+        , content+        , crlf, dd, boundary, dd, crlf ]++    headers =+      [ Header (HdrCustom "Content-disposition")+               ("form-data; name=package; " +++                "filename=\"" ++ takeFileName path ++ "\"")+      , Header HdrContentType "application/x-gzip"+      ]++    crlf = LBS8.pack "\r\n"+    dd   = LBS8.pack "--"++genBoundary :: IO String+genBoundary = do+    i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer+    return $ showHex i ""
+ src/Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,1180 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Extra utils related to the package indexes.+-----------------------------------------------------------------------------+module Distribution.Client.IndexUtils (+  getIndexFileAge,+  getInstalledPackages,+  indexBaseName,+  Configure.getInstalledPackagesMonitorFiles,+  getSourcePackages,+  getSourcePackagesMonitorFiles,++  TotalIndexState,+  getSourcePackagesAtIndexState,+  ActiveRepos,+  filterSkippedActiveRepos,++  Index(..),+  RepoIndexState (..),+  PackageEntry(..),+  parsePackageIndex,+  updateRepoIndexCache,+  updatePackageIndexCacheFile,+  writeIndexTimestamp,+  currentIndexTimestamp,++  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Index as Tar+import qualified Distribution.Client.Tar as Tar+import Distribution.Client.IndexUtils.ActiveRepos+import Distribution.Client.IndexUtils.IndexState+import Distribution.Client.IndexUtils.Timestamp+import Distribution.Client.Types+import Distribution.Verbosity+import Distribution.Parsec (simpleParsecBS)++import Distribution.Package+         ( PackageId, PackageIdentifier(..), mkPackageName+         , Package(..), packageVersion, packageName )+import Distribution.Types.Dependency+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.PackageDescription+         ( GenericPackageDescription(..)+         , PackageDescription(..), emptyPackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, PackageDBStack )+import Distribution.Simple.Program+         ( ProgramDb )+import qualified Distribution.Simple.Configure as Configure+         ( getInstalledPackages, getInstalledPackagesMonitorFiles )+import Distribution.Types.PackageName (PackageName)+import Distribution.Version+         ( Version, VersionRange, mkVersion, intersectVersionRanges )+import Distribution.Simple.Utils+         ( die', warn, info, createDirectoryIfMissingVerbose )+import Distribution.Client.Setup+         ( RepoContext(..) )++import Distribution.PackageDescription.Parsec+         ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe )+import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse++import           Distribution.Solver.Types.PackageIndex (PackageIndex)+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage++import qualified Data.Map as Map+import qualified Data.Set as Set+import Control.Exception+import Data.List (stripPrefix)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Data.ByteString.Char8 as BSS+import Data.ByteString.Lazy (ByteString)+import Distribution.Client.GZipUtils (maybeDecompress)+import Distribution.Client.Utils ( byteStringToFilePath+                                 , tryFindAddSourcePackageDesc )+import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail)+import Distribution.Compat.Time (getFileAge, getModTime)+import System.Directory (doesFileExist, doesDirectoryExist)+import System.FilePath+         ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory )+import qualified System.FilePath.Posix as FilePath.Posix+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO)+import System.IO.Error (isDoesNotExistError)+import Distribution.Compat.Directory (listDirectory)+import Distribution.Utils.Generic (fstOf3)++import qualified Codec.Compression.GZip as GZip++import qualified Hackage.Security.Client    as Sec+import qualified Hackage.Security.Util.Some as Sec++-- | Reduced-verbosity version of 'Configure.getInstalledPackages'+getInstalledPackages :: Verbosity -> Compiler+                     -> PackageDBStack -> ProgramDb+                     -> IO InstalledPackageIndex+getInstalledPackages verbosity comp packageDbs progdb =+    Configure.getInstalledPackages verbosity' comp packageDbs progdb+  where+    verbosity'  = lessVerbose verbosity+++-- | Get filename base (i.e. without file extension) for index-related files+--+-- /Secure/ cabal repositories use a new extended & incremental+-- @01-index.tar@. In order to avoid issues resulting from clobbering+-- new/old-style index data, we save them locally to different names.+--+-- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the+-- @00-index.tar.gz@/@01-index.tar.gz@ file.+indexBaseName :: Repo -> FilePath+indexBaseName repo = repoLocalDir repo </> fn+  where+    fn = case repo of+           RepoSecure {}       -> "01-index"+           RepoRemote {}       -> "00-index"+           RepoLocalNoIndex {} -> "noindex"++------------------------------------------------------------------------+-- Reading the source package index+--++-- Note: 'data IndexState' is defined in+-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles++-- | 'IndexStateInfo' contains meta-information about the resulting+-- filtered 'Cache' 'after applying 'filterCache' according to a+-- requested 'IndexState'.+data IndexStateInfo = IndexStateInfo+    { isiMaxTime  :: !Timestamp+    -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current+    -- filtered view of the cache.+    --+    -- The following property holds+    --+    -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)+    --++    , isiHeadTime :: !Timestamp+    -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest+    -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to+    -- 'isiMaxTime'.+    }++emptyStateInfo :: IndexStateInfo+emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp++-- | Filters a 'Cache' according to an 'IndexState'+-- specification. Also returns 'IndexStateInfo' describing the+-- resulting index cache.+--+-- Note: 'filterCache' is idempotent in the 'Cache' value+filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo)+filterCache IndexStateHead cache = (cache, IndexStateInfo{..})+  where+    isiMaxTime  = cacheHeadTs cache+    isiHeadTime = cacheHeadTs cache+filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})+  where+    cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime }+    isiHeadTime = cacheHeadTs cache0+    isiMaxTime  = maximumTimestamp (map cacheEntryTimestamp ents)+    ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)++-- | Read a repository index from disk, from the local files specified by+-- a list of 'Repo's.+--+-- All the 'SourcePackage's are marked as having come from the appropriate+-- 'Repo'.+--+-- This is a higher level wrapper used internally in cabal-install.+getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb+getSourcePackages verbosity repoCtxt =+    fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing++-- | Variant of 'getSourcePackages' which allows getting the source+-- packages at a particular 'IndexState'.+--+-- Current choices are either the latest (aka HEAD), or the index as+-- it was at a particular time.+--+-- Returns also the total index where repositories'+-- RepoIndexState's are not HEAD. This is used in v2-freeze.+--+getSourcePackagesAtIndexState+    :: Verbosity+    -> RepoContext+    -> Maybe TotalIndexState+    -> Maybe ActiveRepos+    -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)+getSourcePackagesAtIndexState verbosity repoCtxt _ _+  | null (repoContextRepos repoCtxt) = do+      -- In the test suite, we routinely don't have any remote package+      -- servers, so don't bleat about it+      warn (verboseUnmarkOutput verbosity) $+        "No remote package servers have been specified. Usually " +++        "you would have one specified in the config file."+      return (SourcePackageDb {+        packageIndex       = mempty,+        packagePreferences = mempty+      }, headTotalIndexState, ActiveRepos [])+getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do+  let describeState IndexStateHead        = "most recent state"+      describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time++  pkgss <- for (repoContextRepos repoCtxt) $ \r -> do+      let rname :: RepoName+          rname = repoName r++      info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")++      idxState <- case mb_idxState of+        Just totalIdxState -> do+          let idxState = lookupIndexState rname totalIdxState+          info verbosity $ "Using " ++ describeState idxState +++            " as explicitly requested (via command line / project configuration)"+          return idxState+        Nothing -> do+          mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r)+          case mb_idxState' of+            Nothing -> do+              info verbosity "Using most recent state (could not read timestamp file)"+              return IndexStateHead+            Just idxState -> do+              info verbosity $ "Using " ++ describeState idxState +++                " specified from most recent cabal update"+              return idxState++      unless (idxState == IndexStateHead) $+          case r of+            RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories"+            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")+            RepoSecure {} -> pure ()++      let idxState' = case r of+            RepoSecure {} -> idxState+            _             -> IndexStateHead++      (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState'++      case idxState' of+        IndexStateHead -> do+            info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi))+            return ()+        IndexStateTime ts0 -> do+            when (isiMaxTime isi /= ts0) $+                if ts0 > isiMaxTime isi+                    then warn verbosity $+                                   "Requested index-state " ++ prettyShow ts0+                                ++ " is newer than '" ++ unRepoName rname ++ "'!"+                                ++ " Falling back to older state ("+                                ++ prettyShow (isiMaxTime isi) ++ ")."+                    else info verbosity $+                                   "Requested index-state " ++ prettyShow ts0+                                ++ " does not exist in '"++ unRepoName rname ++"'!"+                                ++ " Falling back to older state ("+                                ++ prettyShow (isiMaxTime isi) ++ ")."+            info verbosity ("index-state("++ unRepoName rname ++") = " +++                              prettyShow (isiMaxTime isi) ++ " (HEAD = " +++                              prettyShow (isiHeadTime isi) ++ ")")++      pure RepoData+          { rdRepoName    = rname+          , rdTimeStamp   = isiMaxTime isi+          , rdIndex       = pis+          , rdPreferences = deps+          }++  let activeRepos :: ActiveRepos+      activeRepos = fromMaybe defaultActiveRepos mb_activeRepos++  pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of+    Right x  -> return x+    Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)++  let activeRepos' :: ActiveRepos+      activeRepos' = ActiveRepos+          [ ActiveRepo (rdRepoName rd) strategy+          | (rd, strategy) <- pkgss'+          ]++  let totalIndexState :: TotalIndexState+      totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList+          [ (n, IndexStateTime ts)+          | (RepoData n ts _idx _prefs, _strategy) <- pkgss'+          -- e.g. file+noindex have nullTimestamp as their timestamp+          , ts /= nullTimestamp+          ]++  let addIndex+          :: PackageIndex UnresolvedSourcePackage+          -> (RepoData, CombineStrategy)+          -> PackageIndex UnresolvedSourcePackage+      addIndex acc (RepoData _ _ _   _, CombineStrategySkip)     = acc+      addIndex acc (RepoData _ _ idx _, CombineStrategyMerge)    = PackageIndex.merge acc idx+      addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx++  let pkgs :: PackageIndex UnresolvedSourcePackage+      pkgs = foldl' addIndex mempty pkgss'++  -- Note: preferences combined without using CombineStrategy+  let prefs :: Map PackageName VersionRange+      prefs = Map.fromListWith intersectVersionRanges+          [ (name, range)+          | (RepoData _n _ts _idx prefs', _strategy) <- pkgss'+          , Dependency name range _ <- prefs'+          ]++  _ <- evaluate pkgs+  _ <- evaluate prefs+  _ <- evaluate totalIndexState+  return (SourcePackageDb {+    packageIndex       = pkgs,+    packagePreferences = prefs+  }, totalIndexState, activeRepos')++-- auxiliary data used in getSourcePackagesAtIndexState+data RepoData = RepoData+    { rdRepoName    :: RepoName+    , rdTimeStamp   :: Timestamp+    , rdIndex       :: PackageIndex UnresolvedSourcePackage+    , rdPreferences :: [Dependency]+    }++-- | Read a repository index from disk, from the local file specified by+-- the 'Repo'.+--+-- All the 'SourcePackage's are marked as having come from the given 'Repo'.+--+-- This is a higher level wrapper used internally in cabal-install.+--+readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState+              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)+readRepoIndex verbosity repoCtxt repo idxState =+  handleNotFound $ do+    when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo+    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)+    readPackageIndexCacheFile verbosity mkAvailablePackage+                              (RepoIndex repoCtxt repo)+                              idxState++  where+    mkAvailablePackage pkgEntry = SourcePackage+      { srcpkgPackageId   = pkgid+      , srcpkgDescription = pkgdesc+      , srcpkgSource      = case pkgEntry of+          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing+          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path+      , srcpkgDescrOverride = case pkgEntry of+          NormalPackage _ _ pkgtxt _ -> Just pkgtxt+          _                          -> Nothing+      }+      where+        pkgdesc = packageDesc pkgEntry+        pkgid = packageId pkgEntry++    handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e+      then do+        case repo of+          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote+          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote+          RepoLocalNoIndex local _ -> warn verbosity $+              "Error during construction of local+noindex "+              ++ unRepoName (localRepoName local) ++ " repository index: "+              ++ show e+        return (mempty,mempty,emptyStateInfo)+      else ioError e++    isOldThreshold = 15 --days+    warnIfIndexIsOld dt = do+      when (dt >= isOldThreshold) $ case repo of+        RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt+        RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt+        RepoLocalNoIndex {} -> return ()++    errMissingPackageList repoRemote =+         "The package list for '" ++ unRepoName (remoteRepoName repoRemote)+      ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote+    errOutdatedPackageList repoRemote dt =+         "The package list for '" ++ unRepoName (remoteRepoName repoRemote)+      ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "+      ++ "'cabal update' to get the latest list of available packages."++-- | Return the age of the index file in days (as a Double).+getIndexFileAge :: Repo -> IO Double+getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"++-- | A set of files (or directories) that can be monitored to detect when+-- there might have been a change in the source packages.+--+getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]+getSourcePackagesMonitorFiles repos =+    concat [ [ indexBaseName repo <.> "cache"+             , indexBaseName repo <.> "timestamp" ]+           | repo <- repos ]++-- | It is not necessary to call this, as the cache will be updated when the+-- index is read normally. However you can do the work earlier if you like.+--+updateRepoIndexCache :: Verbosity -> Index -> IO ()+updateRepoIndexCache verbosity index =+    whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index++whenCacheOutOfDate :: Index -> IO () -> IO ()+whenCacheOutOfDate index action = do+  exists <- doesFileExist $ cacheFile index+  if not exists+  then action+  else if localNoIndex index+      then return () -- TODO: don't update cache for local+noindex repositories+      else do+          indexTime <- getModTime $ indexFile index+          cacheTime <- getModTime $ cacheFile index+          when (indexTime > cacheTime) action++localNoIndex :: Index -> Bool+localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True+localNoIndex _ = False++------------------------------------------------------------------------+-- Reading the index file+--++-- | An index entry is either a normal package, or a local build tree reference.+data PackageEntry+  = NormalPackage  PackageId GenericPackageDescription ByteString BlockNo+  | BuildTreeRef BuildTreeRefType+                 PackageId GenericPackageDescription FilePath   BlockNo++-- | A build tree reference is either a link or a snapshot.+data BuildTreeRefType = SnapshotRef | LinkRef+                      deriving (Eq,Show,Generic)++instance Binary BuildTreeRefType+instance Structured BuildTreeRefType++refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType+refTypeFromTypeCode t+  | t == Tar.buildTreeRefTypeCode      = LinkRef+  | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef+  | otherwise                          =+    error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"++typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode+typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode+typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode++instance Package PackageEntry where+  packageId (NormalPackage  pkgid _ _ _) = pkgid+  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid++packageDesc :: PackageEntry -> GenericPackageDescription+packageDesc (NormalPackage  _ descr _ _) = descr+packageDesc (BuildTreeRef _ _ descr _ _) = descr++-- | Parse an uncompressed \"00-index.tar\" repository index file represented+-- as a 'ByteString'.+--++data PackageOrDep = Pkg PackageEntry | Dep Dependency++-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files+--+-- We read the index using 'Tar.read', which gives us a lazily constructed+-- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',+-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a+-- function over this to translate it to a list of IO actions returning+-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of+-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.+parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]+parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read+  where+    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]+    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs+      where+        tryExtractPkg = do+          mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo+          return $ fmap (fmap Pkg) mkPkgEntry++        tryExtractPrefs = do+          prefs' <- maybeToList $ extractPrefs entry+          fmap (return . Just . Dep) prefs'++-- | Turn the 'Entries' data structure from the @tar@ package into a list,+-- and pair each entry with its block number.+--+-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read+-- as far as the list is evaluated.+tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]+tarEntriesList = go 0+  where+    go !_ Tar.Done         = []+    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)+    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'++extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))+extractPkg verbosity entry blockNo = case Tar.entryContent entry of+  Tar.NormalFile content _+     | takeExtension fileName == ".cabal"+    -> case splitDirectories (normalise fileName) of+        [pkgname,vers,_] -> case simpleParsec vers of+          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)+            where+              pkgid  = PackageIdentifier (mkPackageName pkgname) ver+              parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)+              descr = case parsed of+                  Just d  -> d+                  Nothing -> error $ "Couldn't read cabal file "+                                    ++ show fileName+          _ -> Nothing+        _ -> Nothing++  Tar.OtherEntryType typeCode content _+    | Tar.isBuildTreeRefTypeCode typeCode ->+      Just $ do+        let path = byteStringToFilePath content+        dirExists <- doesDirectoryExist path+        result <- if not dirExists then return Nothing+                  else do+                    cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index."+                    descr     <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile+                    return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)+                                                 descr path blockNo+        return result++  _ -> Nothing++  where+    fileName = Tar.entryPath entry++extractPrefs :: Tar.Entry -> Maybe [Dependency]+extractPrefs entry = case Tar.entryContent entry of+  Tar.NormalFile content _+     | FilePath.Posix.takeFileName entrypath == "preferred-versions"+    -> Just prefs+    where+      entrypath = Tar.entryPath entry+      prefs     = parsePreferredVersions content+  _ -> Nothing++parsePreferredVersions :: ByteString -> [Dependency]+parsePreferredVersions = mapMaybe simpleParsec+                       . filter (not . isPrefixOf "--")+                       . lines+                       . BS.Char8.unpack -- TODO: Are we sure no unicode?++------------------------------------------------------------------------+-- Reading and updating the index cache+--++-- | Variation on 'sequence' which evaluates the actions lazily+--+-- Pattern matching on the result list will execute just the first action;+-- more generally pattern matching on the first @n@ '(:)' nodes will execute+-- the first @n@ actions.+lazySequence :: [IO a] -> IO [a]+lazySequence = unsafeInterleaveIO . go+  where+    go []     = return []+    go (x:xs) = do x'  <- x+                   xs' <- lazySequence xs+                   return (x' : xs')++-- | A lazy unfolder for lookup operations which return the current+-- value and (possibly) the next key+lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]+lazyUnfold step = goLazy . Just+  where+    goLazy s = unsafeInterleaveIO (go s)++    go Nothing  = return []+    go (Just k) = do+        (v, mk') <- step k+        vs' <- goLazy mk'+        return ((k,v):vs')++-- | Which index do we mean?+data Index =+    -- | The main index for the specified repository+    RepoIndex RepoContext Repo++    -- | A sandbox-local repository+    -- Argument is the location of the index file+  | SandboxIndex FilePath++indexFile :: Index -> FilePath+indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"+indexFile (SandboxIndex index)   = index++cacheFile :: Index -> FilePath+cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"+cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"++timestampFile :: Index -> FilePath+timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"+timestampFile (SandboxIndex index)   = index `replaceExtension` "timestamp"++-- | Return 'True' if 'Index' uses 01-index format (aka secure repo)+is01Index :: Index -> Bool+is01Index (RepoIndex _ repo) = case repo of+                                 RepoSecure {} -> True+                                 RepoRemote {} -> False+                                 RepoLocalNoIndex {} -> True+is01Index (SandboxIndex _)   = False+++updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()+updatePackageIndexCacheFile verbosity index = do+    info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")+    withIndexEntries verbosity index callback callbackNoIndex+  where+    callback entries = do+        let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)+            cache = Cache { cacheHeadTs  = maxTs+                          , cacheEntries = entries+                          }+        writeIndexCache index cache+        info verbosity ("Index cache updated to index-state "+                        ++ prettyShow (cacheHeadTs cache))++    callbackNoIndex entries = do+        writeNoIndexCache verbosity index $ NoIndexCache entries+        info verbosity "Index cache updated"++-- | Read the index (for the purpose of building a cache)+--+-- The callback is provided with list of cache entries, which is guaranteed to+-- be lazily constructed. This list must ONLY be used in the scope of the+-- callback; when the callback is terminated the file handle to the index will+-- be closed and further attempts to read from the list will result in (pure)+-- I/O exceptions.+--+-- In the construction of the index for a secure repo we take advantage of the+-- index built by the @hackage-security@ library to avoid reading the @.tar@+-- file as much as possible (we need to read it only to extract preferred+-- versions). This helps performance, but is also required for correctness:+-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions+-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);+-- by reading the already-built cache from the security library we will be sure+-- to only read the latest versions of all files.+--+-- TODO: It would be nicer if we actually incrementally updated @cabal@'s+-- cache, rather than reconstruct it from zero on each update. However, this+-- would require a change in the cache format.+withIndexEntries+    :: Verbosity -> Index+    -> ([IndexCacheEntry] -> IO a)+    -> ([NoIndexCacheEntry] -> IO a)+    -> IO a+withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ =+    repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->+      Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do+        -- Incrementally (lazily) read all the entries in the tar file in order,+        -- including all revisions, not just the last revision of each file+        indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)+        callback [ cacheEntry+                 | (dirEntry, indexEntry) <- indexEntries+                 , cacheEntry <- toCacheEntries dirEntry indexEntry ]+  where+    toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry+                   -> [IndexCacheEntry]+    toCacheEntries dirEntry (Sec.Some sie) =+        case Sec.indexEntryPathParsed sie of+          Nothing                            -> [] -- skip unrecognized file+          Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata+          Just (Sec.IndexPkgCabal pkgId)     -> force+              [CachePackageId pkgId blockNo timestamp]+          Just (Sec.IndexPkgPrefs _pkgName)  -> force+              [ CachePreference dep blockNo timestamp+              | dep <- parsePreferredVersions (Sec.indexEntryContent sie)+              ]+      where+        blockNo = Sec.directoryEntryBlockNo dirEntry+        timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $+                              epochTimeToTimestamp $ Sec.indexEntryTime sie++withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do+    dirContents <- listDirectory localDir+    let contentSet = Set.fromList dirContents++    entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do+        case isTarGz file of+            Nothing -> do+                unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $+                    info verbosity $ "Skipping " ++ file+                return Nothing+            Just pkgid | cabalPath `Set.member` contentSet -> do+                contents <- BSS.readFile (localDir </> cabalPath)+                for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->+                    return (CacheGPD gpd contents)+              where+                cabalPath = prettyShow pkgid ++ ".cabal"+            Just pkgId -> do+                -- check for the right named .cabal file in the compressed tarball+                tarGz <- BS.readFile (localDir </> file)+                let tar = GZip.decompress tarGz+                    entries = Tar.read tar++                case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of+                    Just ce -> return (Just ce)+                    Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file++    info verbosity $ "Entries in file+noindex repository " ++ unRepoName name+    for_ entries $ \(CacheGPD gpd _) ->+        info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)++    callback entries+  where+    handler :: IOException -> IO a+    handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e++    isTarGz :: FilePath -> Maybe PackageIdentifier+    isTarGz fp = do+        pfx <- stripSuffix ".tar.gz" fp+        simpleParsec pfx++    stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str))++    -- look for <pkgid>/<pkgname>.cabal inside the tarball+    readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry+    readCabalEntry pkgId entry Nothing+        | filename == Tar.entryPath entry+        , Tar.NormalFile contents _ <- Tar.entryContent entry+        = let bs = BS.toStrict contents+          in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs+      where+        filename =  prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"+    readCabalEntry _ _ x = x++withIndexEntries verbosity index callback _ = do -- non-secure repositories+    withFile (indexFile index) ReadMode $ \h -> do+      bs          <- maybeDecompress `fmap` BS.hGetContents h+      pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs+      callback $ map toCache (catMaybes pkgsOrPrefs)+  where+    toCache :: PackageOrDep -> IndexCacheEntry+    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp+    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo+    toCache (Dep d) = CachePreference d 0 nullTimestamp++readPackageIndexCacheFile :: Package pkg+                          => Verbosity+                          -> (PackageEntry -> pkg)+                          -> Index+                          -> RepoIndexState+                          -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)+readPackageIndexCacheFile verbosity mkPkg index idxState+    | localNoIndex index = do+        cache0 <- readNoIndexCache verbosity index+        pkgs   <- packageNoIndexFromCache verbosity mkPkg cache0+        pure (pkgs, [], emptyStateInfo)++    | otherwise = do+        cache0   <- readIndexCache verbosity index+        indexHnd <- openFile (indexFile index) ReadMode+        let (cache,isi) = filterCache idxState cache0+        (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache+        pure (pkgs,deps,isi)++packageIndexFromCache :: Package pkg+                      => Verbosity+                     -> (PackageEntry -> pkg)+                      -> Handle+                      -> Cache+                      -> IO (PackageIndex pkg, [Dependency])+packageIndexFromCache verbosity mkPkg hnd cache = do+     (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache+     pkgIndex <- evaluate $ PackageIndex.fromList pkgs+     return (pkgIndex, prefs)++packageNoIndexFromCache+    :: forall pkg. Package pkg+    => Verbosity+    -> (PackageEntry -> pkg)+    -> NoIndexCache+    -> IO (PackageIndex pkg)+packageNoIndexFromCache _verbosity mkPkg cache =+     evaluate $ PackageIndex.fromList pkgs+  where+    pkgs =+        [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0+        | CacheGPD gpd bs <- noIndexCacheEntries cache+        , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd+        ]++-- | Read package list+--+-- The result package releases and preference entries are guaranteed+-- to be unique.+--+-- Note: 01-index.tar is an append-only index and therefore contains+-- all .cabal edits and preference-updates. The masking happens+-- here, i.e. the semantics that later entries in a tar file mask+-- earlier ones is resolved in this function.+packageListFromCache :: Verbosity+                     -> (PackageEntry -> pkg)+                     -> Handle+                     -> Cache+                     -> IO ([pkg], [Dependency])+packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries+  where+    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)++    accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do+      -- Given the cache entry, make a package index entry.+      -- The magic here is that we use lazy IO to read the .cabal file+      -- from the index tarball if it turns out that we need it.+      -- Most of the time we only need the package id.+      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do+        pkgtxt <- getEntryContent blockno+        pkg    <- readPackageDescription pkgid pkgtxt+        return (pkg, pkgtxt)++      let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)+      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries++    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do+      -- We have to read the .cabal file eagerly here because we can't cache the+      -- 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 let err = "Error reading package index from cache."+                 file <- tryFindAddSourcePackageDesc verbosity path err+                 PackageDesc.Parse.readGenericPackageDescription normal file+      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)+      accum srcpkgs (srcpkg:btrs) prefs entries++    accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) =+      accum srcpkgs btrs (Map.insert pn pref prefs) entries++    getEntryContent :: BlockNo -> IO ByteString+    getEntryContent blockno = do+      entry <- Tar.hReadEntry hnd blockno+      case Tar.entryContent entry of+        Tar.NormalFile content _size -> return content+        Tar.OtherEntryType typecode content _size+          | Tar.isBuildTreeRefTypeCode typecode+          -> return content+        _ -> interror "unexpected tar entry type"++    readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription+    readPackageDescription pkgid content =+      case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of+        Right gpd                                           -> return gpd+        Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer)+        Left _                                              -> interror "failed to parse .cabal file"+      where+        dummyPackageDescription :: Version -> GenericPackageDescription+        dummyPackageDescription specVer = GenericPackageDescription+            { packageDescription = emptyPackageDescription+                                   { package     = pkgid+                                   , synopsis    = dummySynopsis+                                   }+            , gpdScannedVersion = Just specVer -- tells index scanner to skip this file.+            , genPackageFlags  = []+            , condLibrary      = Nothing+            , condSubLibraries = []+            , condForeignLibs  = []+            , condExecutables  = []+            , condTestSuites   = []+            , condBenchmarks   = []+            }++        dummySynopsis = "<could not be parsed due to unsupported CABAL spec-version>"++    interror :: String -> IO a+    interror msg = die' verbosity $ "internal error when reading package index: " ++ msg+                      ++ "The package index or index cache is probably "+                      ++ "corrupt. Running cabal update might fix it."++++------------------------------------------------------------------------+-- Index cache data structure --++-- | Read the 'Index' cache from the filesystem+--+-- If a corrupted index cache is detected this function regenerates+-- the index cache and then reattempt to read the index once (and+-- 'die's if it fails again).+readIndexCache :: Verbosity -> Index -> IO Cache+readIndexCache verbosity index = do+    cacheOrFail <- readIndexCache' index+    case cacheOrFail of+      Left msg -> do+          warn verbosity $ concat+              [ "Parsing the index cache failed (", msg, "). "+              , "Trying to regenerate the index cache..."+              ]++          updatePackageIndexCacheFile verbosity index++          either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index++      Right res -> return (hashConsCache res)++readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache+readNoIndexCache verbosity index = do+    cacheOrFail <- readNoIndexCache' index+    case cacheOrFail of+      Left msg -> do+          warn verbosity $ concat+              [ "Parsing the index cache failed (", msg, "). "+              , "Trying to regenerate the index cache..."+              ]++          updatePackageIndexCacheFile verbosity index++          either (die' verbosity) return =<< readNoIndexCache' index++      -- we don't hash cons local repository cache, they are hopefully small+      Right res -> return res++-- | Read the 'Index' cache from the filesystem without attempting to+-- regenerate on parsing failures.+readIndexCache' :: Index -> IO (Either String Cache)+readIndexCache' index+  | is01Index index = structuredDecodeFileOrFail (cacheFile index)+  | otherwise       = liftM (Right .read00IndexCache) $+                      BSS.readFile (cacheFile index)++readNoIndexCache' :: Index -> IO (Either String NoIndexCache)+readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)++-- | Write the 'Index' cache to the filesystem+writeIndexCache :: Index -> Cache -> IO ()+writeIndexCache index cache+  | is01Index index = structuredEncodeFile (cacheFile index) cache+  | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)++writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()+writeNoIndexCache verbosity index cache = do+    let path = cacheFile index+    createDirectoryIfMissingVerbose verbosity True (takeDirectory path)+    structuredEncodeFile path cache++-- | Write the 'IndexState' to the filesystem+writeIndexTimestamp :: Index -> RepoIndexState -> IO ()+writeIndexTimestamp index st+  = writeFile (timestampFile index) (prettyShow st)++-- | Read out the "current" index timestamp, i.e., what+-- timestamp you would use to revert to this version+currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp+currentIndexTimestamp verbosity repoCtxt r = do+    mb_is <- readIndexTimestamp (RepoIndex repoCtxt r)+    case mb_is of+      Just (IndexStateTime ts) -> return ts+      _ -> do+        (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead+        return (isiHeadTime isi)++-- | Read the 'IndexState' from the filesystem+readIndexTimestamp :: Index -> IO (Maybe RepoIndexState)+readIndexTimestamp index+  = fmap simpleParsec (readFile (timestampFile index))+        `catchIO` \e ->+            if isDoesNotExistError e+                then return Nothing+                else ioError e++-- | Optimise sharing of equal values inside 'Cache'+--+-- c.f. https://en.wikipedia.org/wiki/Hash_consing+hashConsCache :: Cache -> Cache+hashConsCache cache0+    = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) }+  where+    -- TODO/NOTE:+    --+    -- If/when we redo the binary serialisation via e.g. CBOR and we+    -- are able to use incremental decoding, we may want to move the+    -- hash-consing into the incremental deserialisation, or+    -- alterantively even do something like+    -- http://cbor.schmorp.de/value-sharing+    --+    go _ _ [] = []+    -- for now we only optimise only CachePackageIds since those+    -- represent the vast majority+    go !pns !pvs (CachePackageId pid bno ts : rest)+        = CachePackageId pid' bno ts : go pns' pvs' rest+      where+        !pid' = PackageIdentifier pn' pv'+        (!pn',!pns') = mapIntern pn pns+        (!pv',!pvs') = mapIntern pv pvs+        PackageIdentifier pn pv = pid++    go pns pvs (x:xs) = x : go pns pvs xs++    mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k)+    mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m)++-- | Cabal caches various information about the Hackage index+data Cache = Cache+    { cacheHeadTs  :: Timestamp+      -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the+      -- invariant of 'cacheEntries' being in chronological order is+      -- violated, this corresponds to the last (seen) 'Timestamp' in+      -- 'cacheEntries'+    , cacheEntries :: [IndexCacheEntry]+    }+  deriving (Show, Generic)++instance NFData Cache where+    rnf = rnf . cacheEntries++-- | Cache format for 'file+noindex' repositories+newtype NoIndexCache = NoIndexCache+    { noIndexCacheEntries :: [NoIndexCacheEntry]+    }+  deriving (Show, Generic)++instance NFData NoIndexCache where+    rnf = rnf . noIndexCacheEntries++-- | Tar files are block structured with 512 byte blocks. Every header and file+-- content starts on a block boundary.+--+type BlockNo = Word32 -- Tar.TarEntryOffset++data IndexCacheEntry+    = CachePackageId PackageId !BlockNo !Timestamp+    | CachePreference Dependency !BlockNo !Timestamp+    | CacheBuildTreeRef !BuildTreeRefType !BlockNo+      -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build+  deriving (Eq,Show,Generic)++data NoIndexCacheEntry+    = CacheGPD GenericPackageDescription !BSS.ByteString+  deriving (Eq,Show,Generic)++instance NFData IndexCacheEntry where+    rnf (CachePackageId pkgid _ _) = rnf pkgid+    rnf (CachePreference dep _ _) = rnf dep+    rnf (CacheBuildTreeRef _ _) = ()++instance NFData NoIndexCacheEntry where+    rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs++cacheEntryTimestamp :: IndexCacheEntry -> Timestamp+cacheEntryTimestamp (CacheBuildTreeRef _ _)  = nullTimestamp+cacheEntryTimestamp (CachePreference _ _ ts) = ts+cacheEntryTimestamp (CachePackageId _ _ ts)  = ts++----------------------------------------------------------------------------+-- new binary 01-index.cache format++instance Binary Cache+instance Binary IndexCacheEntry+instance Binary NoIndexCache++instance Structured Cache+instance Structured IndexCacheEntry+instance Structured NoIndexCache++-- | We need to save only .cabal file contents+instance Binary NoIndexCacheEntry where+    put (CacheGPD _ bs) = put bs++    get = do+        bs <- get+        case parseGenericPackageDescriptionMaybe bs of+            Just gpd -> return (CacheGPD gpd bs)+            Nothing  -> fail "Failed to parse GPD"++instance Structured NoIndexCacheEntry where+    structure = nominalStructure++----------------------------------------------------------------------------+-- legacy 00-index.cache format++packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String+packageKey = "pkg:"+blocknoKey = "b#"+buildTreeRefKey     = "build-tree-ref:"+preferredVersionKey = "pref-ver:"++-- legacy 00-index.cache format+read00IndexCache :: BSS.ByteString -> Cache+read00IndexCache bs = Cache+  { cacheHeadTs  = nullTimestamp+  , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs+  }++read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry+read00IndexCacheEntry = \line ->+  case BSS.words line of+    [key, pkgnamestr, pkgverstr, sep, blocknostr]+      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->+      case (parseName pkgnamestr, parseVer pkgverstr [],+            parseBlockNo blocknostr) of+        (Just pkgname, Just pkgver, Just blockno)+          -> Just (CachePackageId (PackageIdentifier pkgname pkgver)+                                  blockno nullTimestamp)+        _ -> Nothing+    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->+      case (parseRefType typecodestr, parseBlockNo blocknostr) of+        (Just refType, Just blockno)+          -> Just (CacheBuildTreeRef refType blockno)+        _ -> Nothing++    (key: remainder) | key == BSS.pack preferredVersionKey -> do+      pref <- simpleParsecBS (BSS.unwords remainder)+      return $ CachePreference pref 0 nullTimestamp++    _  -> Nothing+  where+    parseName str+      | BSS.all (\c -> isAlphaNum c || c == '-') str+                  = Just (mkPackageName (BSS.unpack str))+      | otherwise = Nothing++    parseVer str vs =+      case BSS.readInt str of+        Nothing        -> Nothing+        Just (v, str') -> case BSS.uncons str' of+          Just ('.', str'') -> parseVer str'' (v:vs)+          Just _            -> Nothing+          Nothing           -> Just (mkVersion (reverse (v:vs)))++    parseBlockNo str =+      case BSS.readInt str of+        Just (blockno, remainder)+          | BSS.null remainder -> Just (fromIntegral blockno)+        _                      -> Nothing++    parseRefType str =+      case BSS.uncons str of+        Just (typeCode, remainder)+          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode+            -> Just (refTypeFromTypeCode typeCode)+        _   -> Nothing++-- legacy 00-index.cache format+show00IndexCache :: Cache -> String+show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries++show00IndexCacheEntry :: IndexCacheEntry -> String+show00IndexCacheEntry entry = unwords $ case entry of+    CachePackageId pkgid b _ ->+        [ packageKey+        , prettyShow (packageName pkgid)+        , prettyShow (packageVersion pkgid)+        , blocknoKey+        , show b+        ]+    CacheBuildTreeRef tr b ->+        [ buildTreeRefKey+        , [typeCodeFromRefType tr]+        , show b+        ]+    CachePreference dep _ _  ->+        [ preferredVersionKey+        , prettyShow dep+        ]
+ src/Distribution/Client/IndexUtils/ActiveRepos.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Distribution.Client.IndexUtils.ActiveRepos (+    ActiveRepos (..),+    defaultActiveRepos,+    filterSkippedActiveRepos,+    ActiveRepoEntry (..),+    CombineStrategy (..),+    organizeByRepos,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Client.Types.RepoName (RepoName (..))+import Prelude ()++import Distribution.Parsec (parsecLeadingCommaNonEmpty)++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++-- | Ordered list of active repositories.+newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]+  deriving (Eq, Show, Generic)++defaultActiveRepos :: ActiveRepos+defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ]++-- | Note, this does nothing if 'ActiveRepoRest' is present.+filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos+filterSkippedActiveRepos repos@(ActiveRepos entries)+    | any isActiveRepoRest entries = repos+    | otherwise                    = ActiveRepos (filter notSkipped entries)+  where+    isActiveRepoRest (ActiveRepoRest _) = True+    isActiveRepoRest _                  = False++    notSkipped (ActiveRepo _ CombineStrategySkip) = False+    notSkipped _                                  = True++instance Binary ActiveRepos+instance Structured ActiveRepos+instance NFData ActiveRepos++instance Pretty ActiveRepos where+    pretty (ActiveRepos [])+        = Disp.text ":none"+    pretty (ActiveRepos repos)+        = Disp.hsep+        $ Disp.punctuate Disp.comma+        $ map pretty repos++-- | Note: empty string is not valid 'ActiveRepos'.+--+-- >>> simpleParsec "" :: Maybe ActiveRepos+-- Nothing+--+-- >>> simpleParsec ":none" :: Maybe ActiveRepos+-- Just (ActiveRepos [])+--+-- >>> simpleParsec ":rest" :: Maybe ActiveRepos+-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge])+--+-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos+-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])+--+instance Parsec ActiveRepos where+    parsec = ActiveRepos [] <$ P.try (P.string ":none")+        <|> do+            repos <- parsecLeadingCommaNonEmpty parsec+            return (ActiveRepos (toList repos))++data ActiveRepoEntry+    = ActiveRepoRest CombineStrategy        -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'+    | ActiveRepo RepoName CombineStrategy   -- ^ explicit repository name+  deriving (Eq, Show, Generic)++instance Binary ActiveRepoEntry+instance Structured ActiveRepoEntry+instance NFData ActiveRepoEntry++instance Pretty ActiveRepoEntry where+    pretty (ActiveRepoRest s) =+        Disp.text ":rest" <<>> Disp.colon <<>> pretty s+    pretty (ActiveRepo r s) =+        pretty r <<>> Disp.colon <<>> pretty s++instance Parsec ActiveRepoEntry where+    parsec = leadColon <|> leadRepo where+        leadColon = do+            _ <- P.char ':'+            token <- P.munch1 isAlpha+            case token of+                "rest" -> ActiveRepoRest <$> strategyP+                "repo" -> P.char ':' *> leadRepo+                _      -> P.unexpected $ "Unknown active repository entry type: " ++ token++        leadRepo = do+            r <- parsec+            s <- strategyP+            return (ActiveRepo r s)++        strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)++data CombineStrategy+    = CombineStrategySkip     -- ^ skip this repository+    | CombineStrategyMerge    -- ^ merge existing versions+    | CombineStrategyOverride -- ^ if later repository specifies a package,+                              --   all package versions are replaced+  deriving (Eq, Show, Enum, Bounded, Generic)++instance Binary CombineStrategy+instance Structured CombineStrategy+instance NFData CombineStrategy++instance Pretty CombineStrategy where+    pretty CombineStrategySkip     = Disp.text "skip"+    pretty CombineStrategyMerge    = Disp.text "merge"+    pretty CombineStrategyOverride = Disp.text "override"++instance Parsec CombineStrategy where+    parsec = P.choice+        [ CombineStrategySkip     <$ P.string "skip"+        , CombineStrategyMerge    <$ P.string "merge"+        , CombineStrategyOverride <$ P.string "override"+        ]++-------------------------------------------------------------------------------+-- Organisation+-------------------------------------------------------------------------------++-- | Sort values 'RepoName' according to 'ActiveRepos' list.+--+-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"]+-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos+-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]+--+-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos+-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]+--+-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos+-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)]+--+-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos+-- Left "no repository provided d"+--+-- Note: currently if 'ActiveRepoRest' is provided more than once,+-- rest-repositories will be multiple times in the output.+--+organizeByRepos+    :: forall a. ActiveRepos+    -> (a -> RepoName)+    -> [a]+    -> Either String [(a, CombineStrategy)]+organizeByRepos (ActiveRepos xs0) sel ys0 =+    -- here we use lazyness to do only one traversal+    let (rest, result) = case go rest xs0 ys0 of+            Right (rest', result') -> (rest', Right result')+            Left err               -> ([],    Left err)+    in result+  where+    go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])+    go _rest []                      ys = Right (ys, [])+    go  rest (ActiveRepoRest s : xs) ys =+        go rest xs ys <&> \(rest', result) ->+           (rest', map (\x -> (x, s)) rest ++ result)+    go  rest (ActiveRepo r s : xs)   ys = do+        (z, zs) <- extract r ys+        go rest xs zs <&> \(rest', result) ->+            (rest', (z, s) : result)++    extract :: RepoName -> [a] -> Either String (a, [a])+    extract r = loop id where+        loop _acc []     = Left $ "no repository provided " ++ prettyShow r+        loop  acc (x:xs)+            | sel x == r = Right (x, acc xs)+            | otherwise  = loop (acc . (x :)) xs++    (<&>)+        :: Either err ([s], b)+        -> (([s], b) -> ([s], c))+        -> Either err ([s], c)+    (<&>) = flip fmap
+ src/Distribution/Client/IndexUtils/IndexState.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils.IndexUtils+-- Copyright   :  (c) 2016 Herbert Valerio Riedel+-- License     :  BSD3+--+-- Package repositories index state.+--+module Distribution.Client.IndexUtils.IndexState (+    RepoIndexState(..),+    TotalIndexState,+    headTotalIndexState,+    makeTotalIndexState,+    lookupIndexState,+    insertIndexState,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Client.IndexUtils.Timestamp (Timestamp)+import Distribution.Client.Types.RepoName       (RepoName (..))++import Distribution.Parsec (parsecLeadingCommaNonEmpty)++import qualified Data.Map.Strict                 as Map+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-------------------------------------------------------------------------------+-- Total index state+-------------------------------------------------------------------------------++-- | Index state of multiple repositories+data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState)+  deriving (Eq, Show, Generic)++instance Binary TotalIndexState+instance Structured TotalIndexState+instance NFData TotalIndexState++instance Pretty TotalIndexState where+    pretty (TIS IndexStateHead m)+        | not (Map.null m)+        = Disp.hsep $ Disp.punctuate Disp.comma+            [ pretty rn Disp.<+> pretty idx+            | (rn, idx) <- Map.toList m+            ]+    pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where+        go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx++-- |+--+-- >>> simpleParsec "HEAD" :: Maybe TotalIndexState+-- Just (TIS IndexStateHead (fromList []))+--+-- >>> simpleParsec "" :: Maybe TotalIndexState+-- Nothing+--+-- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState+-- Just (TIS IndexStateHead (fromList []))+--+-- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState+-- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)]))+--+-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState+-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))]))+--+instance Parsec TotalIndexState where+    parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where+        single0 = startsWithRepoName <|> TokTimestamp <$> parsec+        startsWithRepoName = do+            reponame <- parsec+            -- the "HEAD" is technically a valid reponame...+            if reponame == RepoName "HEAD"+            then return TokHead+            else do+                P.spaces+                TokRepo reponame <$> parsec++        add :: TotalIndexState -> Tok -> TotalIndexState+        add _           TokHead           = headTotalIndexState+        add _           (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty+        add (TIS def m) (TokRepo rn idx)  = TIS def (Map.insert rn idx m)++-- used in Parsec TotalIndexState implementation+data Tok+    = TokRepo RepoName RepoIndexState+    | TokTimestamp Timestamp+    | TokHead++-- | Remove non-default values from 'TotalIndexState'.+normalise :: TotalIndexState -> TotalIndexState+normalise (TIS def m) = TIS def (Map.filter (/= def) m)++-- | 'TotalIndexState' where all repositories are at @HEAD@ index state.+headTotalIndexState :: TotalIndexState+headTotalIndexState = TIS IndexStateHead Map.empty++-- | Create 'TotalIndexState'.+makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState+makeTotalIndexState def m = normalise (TIS def m)++-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'.+lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState+lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m++-- | Insert a 'RepoIndexState' to 'TotalIndexState'.+insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState+insertIndexState rn idx (TIS def m)+    | idx == def = TIS def (Map.delete rn m)+    | otherwise  = TIS def (Map.insert rn idx m)++-------------------------------------------------------------------------------+-- Repository index state+-------------------------------------------------------------------------------++-- | Specification of the state of a specific repo package index+data RepoIndexState+    = IndexStateHead -- ^ Use all available entries+    | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time+    deriving (Eq,Generic,Show)++instance Binary RepoIndexState+instance Structured RepoIndexState+instance NFData RepoIndexState++instance Pretty RepoIndexState where+    pretty IndexStateHead = Disp.text "HEAD"+    pretty (IndexStateTime ts) = pretty ts++instance Parsec RepoIndexState where+    parsec = parseHead <|> parseTime where+        parseHead = IndexStateHead <$ P.string "HEAD"+        parseTime = IndexStateTime <$> parsec
+ src/Distribution/Client/IndexUtils/Timestamp.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils.Timestamp+-- Copyright   :  (c) 2016 Herbert Valerio Riedel+-- License     :  BSD3+--+-- Timestamp type used in package indexes++module Distribution.Client.IndexUtils.Timestamp+    ( Timestamp+    , nullTimestamp+    , epochTimeToTimestamp+    , timestampToUTCTime+    , utcTimeToTimestamp+    , maximumTimestamp+    ) where++import Distribution.Client.Compat.Prelude++-- read is needed for Text instance+import Prelude (read)++import Data.Time             (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)++import qualified Codec.Archive.Tar.Entry         as Tar+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).+newtype Timestamp = TS Int64 -- Tar.EpochTime+                  deriving (Eq,Ord,Enum,NFData,Show,Generic)++epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp+epochTimeToTimestamp et+  | ts == nullTimestamp  = Nothing+  | otherwise            = Just ts+  where+    ts = TS et++timestampToUTCTime :: Timestamp -> Maybe UTCTime+timestampToUTCTime (TS t)+  | t == minBound  = Nothing+  | otherwise      = Just $ posixSecondsToUTCTime (fromIntegral t)++utcTimeToTimestamp :: UTCTime -> Maybe Timestamp+utcTimeToTimestamp utct+  | minTime <= t, t <= maxTime  = Just (TS (fromIntegral t))+  | otherwise                   = Nothing+  where+    maxTime = toInteger (maxBound :: Int64)+    minTime = toInteger (succ minBound :: Int64)+    t :: Integer+    t = round . utcTimeToPOSIXSeconds $ utct++-- | Compute the maximum 'Timestamp' value+--+-- Returns 'nullTimestamp' for the empty list.  Also note that+-- 'nullTimestamp' compares as smaller to all non-'nullTimestamp'+-- values.+maximumTimestamp :: [Timestamp] -> Timestamp+maximumTimestamp [] = nullTimestamp+maximumTimestamp xs@(_:_) = maximum xs++-- returns 'Nothing' if not representable as 'Timestamp'+posixSecondsToTimestamp :: Integer -> Maybe Timestamp+posixSecondsToTimestamp pt+  | minTs <= pt, pt <= maxTs  = Just (TS (fromInteger pt))+  | otherwise                 = Nothing+  where+    maxTs = toInteger (maxBound :: Int64)+    minTs = toInteger (succ minBound :: Int64)++-- | Pretty-prints 'Timestamp' in ISO8601/RFC3339 format+-- (e.g. @"2017-12-31T23:59:59Z"@)+--+-- Returns empty string for 'nullTimestamp' in order for+--+-- > null (display nullTimestamp) == True+--+-- to hold.+showTimestamp :: Timestamp -> String+showTimestamp ts = case timestampToUTCTime ts of+    Nothing          -> ""+    -- Note: we don't use 'formatTime' here to avoid incurring a+    -- dependency on 'old-locale' for older `time` libs+    Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z"+  where+    showTOD = show . timeToTimeOfDay++instance Binary Timestamp+instance Structured Timestamp++instance Pretty Timestamp where+    pretty = Disp.text . showTimestamp++instance Parsec Timestamp where+    parsec = parsePosix <|> parseUTC+      where+        -- | Parses unix timestamps, e.g. @"\@1474626019"@+        parsePosix = do+            _ <- P.char '@'+            t <- P.integral -- note, no negative timestamps+            maybe (fail (show t ++ " is not representable as timestamp")) return $+                posixSecondsToTimestamp t++        -- | Parses ISO8601/RFC3339-style UTC timestamps,+        -- e.g. @"2017-12-31T23:59:59Z"@+        --+        -- TODO: support numeric tz offsets; allow to leave off seconds+        parseUTC = do+            -- Note: we don't use 'Data.Time.Format.parseTime' here since+            -- we want more control over the accepted formats.++            ye <- parseYear+            _ <- P.char '-'+            mo   <- parseTwoDigits+            _ <- P.char '-'+            da   <- parseTwoDigits+            _ <- P.char 'T'++            utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $+                       fromGregorianValid ye mo da++            ho   <- parseTwoDigits+            _ <- P.char ':'+            mi   <- parseTwoDigits+            _ <- P.char ':'+            se   <- parseTwoDigits+            _ <- P.char 'Z'++            utctDayTime <- maybe (fail (show (ho,mi,se) ++  " is not valid time of day")) (return . timeOfDayToTime) $+                           makeTimeOfDayValid ho mi (realToFrac (se::Int))++            let utc = UTCTime {..}++            maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc++        parseTwoDigits = do+            d1 <- P.satisfy isDigit+            d2 <- P.satisfy isDigit+            return (read [d1,d2])++        -- A year must have at least 4 digits; e.g. "0097" is fine,+        -- while "97" is not c.f. RFC3339 which+        -- deprecates 2-digit years+        parseYear = do+            sign <- P.option ' ' (P.char '-')+            ds <- P.munch1 isDigit+            when (length ds < 4) $ fail "Year should have at least 4 digits"+            return (read (sign:ds))++-- | Special timestamp value to be used when 'timestamp' is+-- missing/unknown/invalid+nullTimestamp :: Timestamp+nullTimestamp = TS minBound
+ src/Distribution/Client/Init.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Implementation of the 'cabal init' command, which creates an initial .cabal+-- file for a project.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init (++    -- * Commands+    initCabal+  , incVersion++  ) where++import Distribution.Client.Init.Command+  ( initCabal, incVersion )
+ src/Distribution/Client/Init/Command.hs view
@@ -0,0 +1,749 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Command+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Implementation of the 'cabal init' command, which creates an initial .cabal+-- file for a project.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Command+  ( -- * Commands+    initCabal+  , incVersion++    -- * Helpers+  , getSimpleProject+  , getLibOrExec+  , getCabalVersion+  , getPackageName+  , getVersion+  , getLicense+  , getAuthorInfo+  , getHomepage+  , getSynopsis+  , getCategory+  , getExtraSourceFiles+  , getAppDir+  , getSrcDir+  , getGenTests+  , getTestDir+  , getLanguage+  , getGenComments+  , getModulesBuildToolsAndDeps+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)++import System.IO+  ( hSetBuffering, stdout, BufferMode(..) )+import System.Directory+  ( getCurrentDirectory, doesDirectoryExist, getDirectoryContents )+import System.FilePath+  ( (</>), takeBaseName, equalFilePath )++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Control.Monad+  ( (>=>) )+import Control.Arrow+  ( (&&&), (***) )++import Distribution.CabalSpecVersion+  ( CabalSpecVersion (..), showCabalSpecVersion )+import Distribution.Version+  ( Version, mkVersion, alterVersion, majorBoundVersion+  , orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange )+import Distribution.ModuleName+  ( ModuleName )  -- And for the Text instance+import Distribution.InstalledPackageInfo+  ( InstalledPackageInfo, exposed )+import qualified Distribution.Package as P+import qualified Distribution.SPDX as SPDX+import Language.Haskell.Extension ( Language(..) )++import Distribution.Client.Init.Defaults+  ( defaultApplicationDir, defaultCabalVersion, myLibModule, defaultSourceDir )+import Distribution.Client.Init.FileCreators+  ( writeLicense, writeChangeLog, createDirectories, createLibHs, createMainHs+  , createTestSuiteIfEligible, writeCabalFile )+import Distribution.Client.Init.Prompt+  ( prompt, promptYesNo, promptStr, promptList, maybePrompt+  , promptListOptional )+import Distribution.Client.Init.Utils+  ( eligibleForTestSuite,  message )+import Distribution.Client.Init.Types+  ( InitFlags(..), PackageType(..), Category(..)+  , displayPackageType )+import Distribution.Client.Init.Heuristics+  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,+    SourceFileEntry(..),+    scanForModules, neededBuildPrograms )++import Distribution.Simple.Flag+  ( maybeToFlag )+import Distribution.Simple.Setup+  ( Flag(..), flagToMaybe )+import Distribution.Simple.Configure+  ( getInstalledPackages )+import Distribution.Simple.Compiler+  ( PackageDBStack, Compiler )+import Distribution.Simple.Program+  ( ProgramDb )+import Distribution.Simple.PackageIndex+  ( InstalledPackageIndex, moduleNameIndex )+import Distribution.Simple.Utils+  ( die' )++import Distribution.Solver.Types.PackageIndex+  ( elemByPackageName )++import Distribution.Client.IndexUtils+  ( getSourcePackages )+import Distribution.Client.Types+  ( SourcePackageDb(..) )+import Distribution.Client.Setup+  ( RepoContext(..) )++initCabal :: Verbosity+          -> PackageDBStack+          -> RepoContext+          -> Compiler+          -> ProgramDb+          -> InitFlags+          -> IO ()+initCabal verbosity packageDBs repoCtxt comp progdb initFlags = do++  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+  sourcePkgDb <- getSourcePackages verbosity repoCtxt++  hSetBuffering stdout NoBuffering++  initFlags' <- extendFlags verbosity installedPkgIndex sourcePkgDb initFlags++  case license initFlags' of+    Flag SPDX.NONE -> return ()+    _              -> writeLicense initFlags'+  writeChangeLog initFlags'+  createDirectories (sourceDirs initFlags')+  createLibHs initFlags'+  createDirectories (applicationDirs initFlags')+  createMainHs initFlags'+  createTestSuiteIfEligible initFlags'+  success <- writeCabalFile initFlags'++  when success $ generateWarnings initFlags'++---------------------------------------------------------------------------+--  Flag acquisition  -----------------------------------------------------+---------------------------------------------------------------------------++-- | Fill in more details in InitFlags by guessing, discovering, or prompting+-- the user.+extendFlags :: Verbosity -> InstalledPackageIndex -> SourcePackageDb -> InitFlags -> IO InitFlags+extendFlags verbosity pkgIx sourcePkgDb =+      getSimpleProject+  >=> getLibOrExec+  >=> getCabalVersion+  >=> getPackageName verbosity sourcePkgDb False+  >=> getVersion+  >=> getLicense+  >=> getAuthorInfo+  >=> getHomepage+  >=> getSynopsis+  >=> getCategory+  >=> getExtraSourceFiles+  >=> getAppDir+  >=> getSrcDir+  >=> getGenTests+  >=> getTestDir+  >=> getLanguage+  >=> getGenComments+  >=> getModulesBuildToolsAndDeps pkgIx++-- | Combine two actions which may return a value, preferring the first. That+--   is, run the second action only if the first doesn't return a value.+infixr 1 ?>>+(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)+f ?>> g = do+  ma <- f+  if isJust ma+    then return ma+    else g++-- | Ask if a simple project with sensible defaults should be created.+getSimpleProject :: InitFlags -> IO InitFlags+getSimpleProject flags = do+  simpleProj <-     return (flagToMaybe $ simpleProject flags)+                ?>> maybePrompt flags+                    (promptYesNo+                      "Should I generate a simple project with sensible defaults"+                      (Just True))+  return $ case maybeToFlag simpleProj of+    Flag True ->+      flags { interactive = Flag False+            , simpleProject = Flag True+            , packageType = Flag LibraryAndExecutable+            , cabalVersion = Flag defaultCabalVersion+            }+    simpleProjFlag@_ ->+      flags { simpleProject = simpleProjFlag }+++-- | Get the version of the cabal spec to use.+--+-- The spec version can be specified by the InitFlags cabalVersion field. If+-- none is specified then the user is prompted to pick from a list of+-- supported versions (see code below).+getCabalVersion :: InitFlags -> IO InitFlags+getCabalVersion flags = do+  cabVer <-     return (flagToMaybe $ cabalVersion flags)+            ?>> maybePrompt flags (either (const defaultCabalVersion) id `fmap`+                                  promptList "Please choose version of the Cabal specification to use"+                                  [CabalSpecV1_10, CabalSpecV2_0, CabalSpecV2_2, CabalSpecV2_4, CabalSpecV3_0]+                                  (Just defaultCabalVersion) displayCabalVersion False)+            ?>> return (Just defaultCabalVersion)++  return $  flags { cabalVersion = maybeToFlag cabVer }++  where+    displayCabalVersion :: CabalSpecVersion -> String+    displayCabalVersion v = case v of+      CabalSpecV1_10 -> "1.10   (legacy)"+      CabalSpecV2_0  -> "2.0    (+ support for Backpack, internal sub-libs, '^>=' operator)"+      CabalSpecV2_2  -> "2.2    (+ support for 'common', 'elif', redundant commas, SPDX)"+      CabalSpecV2_4  -> "2.4    (+ support for '**' globbing)"+      CabalSpecV3_0  -> "3.0    (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"+      _              -> showCabalSpecVersion v++++-- | Get the package name: use the package directory (supplied, or the current+--   directory by default) as a guess. It looks at the SourcePackageDb to avoid+--   using an existing package name.+getPackageName :: Verbosity -> SourcePackageDb -> Bool -> InitFlags -> IO InitFlags+getPackageName verbosity sourcePkgDb forceAsk flags = do+  guess <- maybe (getCurrentDirectory >>= guessPackageName) pure+             =<< traverse guessPackageName (flagToMaybe $ packageDir flags)++  pkgName' <- case (flagToMaybe $ packageName flags) >>= maybeForceAsk of+    Just pkgName -> return $ Just $ pkgName+    _ -> maybePrompt flags (prompt "Package name" (Just guess))+  let pkgName = fromMaybe guess pkgName'++  chooseAgain <- if isPkgRegistered pkgName+                   then do+                     answer' <- maybePrompt flags (promptYesNo (promptOtherNameMsg pkgName) (Just True))+                     case answer' of+                       Just answer -> return answer+                       _ -> die' verbosity $ inUseMsg pkgName+                 else+                   return False++  if chooseAgain+    then getPackageName verbosity sourcePkgDb True flags+    else return $ flags { packageName = Flag pkgName }++  where+    maybeForceAsk x = if forceAsk then Nothing else Just x++    isPkgRegistered pkg = elemByPackageName (packageIndex sourcePkgDb) pkg++    inUseMsg pkgName = "The name " ++ (P.unPackageName pkgName) +++                       " is already in use by another package on Hackage."++    promptOtherNameMsg pkgName = (inUseMsg pkgName) +++                                 " Do you want to choose a different name"++-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user+--  if possible.+getVersion :: InitFlags -> IO InitFlags+getVersion flags = do+  let v = Just $ mkVersion [0,1,0,0]+  v' <-     return (flagToMaybe $ version flags)+        ?>> maybePrompt flags (prompt "Package version" v)+        ?>> return v+  return $ flags { version = maybeToFlag v' }++-- | Choose a license for the package.+--+-- The license can come from Initflags (license field), if it is not present+-- then prompt the user from a predefined list of licenses.+getLicense :: InitFlags -> IO InitFlags+getLicense flags = do+  elic <- return (fmap Right $ flagToMaybe $ license flags)+      ?>> maybePrompt flags (promptList "Please choose a license" listedLicenses (Just SPDX.NONE) prettyShow True)++  case elic of+      Nothing          -> return flags { license = NoFlag }+      Just (Right lic) -> return flags { license = Flag lic }+      Just (Left str)  -> case eitherParsec str of+          Right lic -> return flags { license = Flag lic }+          -- on error, loop+          Left err -> do+              putStrLn "The license must be a valid SPDX expression."+              putStrLn err+              getLicense flags+  where+    -- perfectly we'll have this and writeLicense (in FileCreators)+    -- in a single file+    listedLicenses =+      SPDX.NONE :+      map (\lid -> SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing))+      [ SPDX.BSD_2_Clause+      , SPDX.BSD_3_Clause+      , SPDX.Apache_2_0+      , SPDX.MIT+      , SPDX.MPL_2_0+      , SPDX.ISC++      , SPDX.GPL_2_0_only+      , SPDX.GPL_3_0_only+      , SPDX.LGPL_2_1_only+      , SPDX.LGPL_3_0_only+      , SPDX.AGPL_3_0_only++      , SPDX.GPL_2_0_or_later+      , SPDX.GPL_3_0_or_later+      , SPDX.LGPL_2_1_or_later+      , SPDX.LGPL_3_0_or_later+      , SPDX.AGPL_3_0_or_later+      ]++-- | The author's name and email. Prompt, or try to guess from an existing+--   darcs repo.+getAuthorInfo :: InitFlags -> IO InitFlags+getAuthorInfo flags = do+  (authorName, authorEmail)  <-+    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail+  authorName'  <-     return (flagToMaybe $ author flags)+                  ?>> maybePrompt flags (promptStr "Author name" authorName)+                  ?>> return authorName++  authorEmail' <-     return (flagToMaybe $ email flags)+                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)+                  ?>> return authorEmail++  return $ flags { author = maybeToFlag authorName'+                 , email  = maybeToFlag authorEmail'+                 }++-- | Prompt for a homepage URL for the package.+getHomepage :: InitFlags -> IO InitFlags+getHomepage flags = do+  hp  <- queryHomepage+  hp' <-     return (flagToMaybe $ homepage flags)+         ?>> maybePrompt flags (promptStr "Project homepage URL" hp)+         ?>> return hp++  return $ flags { homepage = maybeToFlag hp' }++-- | Right now this does nothing, but it could be changed to do some+--   intelligent guessing.+queryHomepage :: IO (Maybe String)+queryHomepage = return Nothing     -- get default remote darcs repo?++-- | Prompt for a project synopsis.+getSynopsis :: InitFlags -> IO InitFlags+getSynopsis flags = do+  syn <-     return (flagToMaybe $ synopsis flags)+         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)++  return $ flags { synopsis = maybeToFlag syn }++-- | Prompt for a package category.+--   Note that it should be possible to do some smarter guessing here too, i.e.+--   look at the name of the top level source directory.+getCategory :: InitFlags -> IO InitFlags+getCategory flags = do+  cat <-     return (flagToMaybe $ category flags)+         ?>> fmap join (maybePrompt flags+                         (promptListOptional "Project category" [Codec ..]))+  return $ flags { category = maybeToFlag cat }++-- | Try to guess extra source files (don't prompt the user).+getExtraSourceFiles :: InitFlags -> IO InitFlags+getExtraSourceFiles flags = do+  extraSrcFiles <-     return (extraSrc flags)+                   ?>> Just `fmap` guessExtraSourceFiles flags++  return $ flags { extraSrc = extraSrcFiles }++defaultChangeLog :: FilePath+defaultChangeLog = "CHANGELOG.md"++-- | Try to guess things to include in the extra-source-files field.+--   For now, we just look for things in the root directory named+--   'readme', 'changes', or 'changelog', with any sort of+--   capitalization and any extension.+guessExtraSourceFiles :: InitFlags -> IO [FilePath]+guessExtraSourceFiles flags = do+  dir <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  files <- getDirectoryContents dir+  let extraFiles = filter isExtra files+  if any isLikeChangeLog extraFiles+    then return extraFiles+    else return (defaultChangeLog : extraFiles)++  where+    isExtra = likeFileNameBase ("README" : changeLogLikeBases)+    isLikeChangeLog = likeFileNameBase changeLogLikeBases+    likeFileNameBase candidates = (`elem` candidates) . map toUpper . takeBaseName+    changeLogLikeBases = ["CHANGES", "CHANGELOG"]++-- | Ask whether the project builds a library or executable.+getLibOrExec :: InitFlags -> IO InitFlags+getLibOrExec flags = do+  pkgType <-     return (flagToMaybe $ packageType flags)+           ?>> maybePrompt flags (either (const Executable) id `fmap`+                                   promptList "What does the package build"+                                   [Executable, Library, LibraryAndExecutable]+                                   Nothing displayPackageType False)+           ?>> return (Just Executable)++  -- If this package contains an executable, get the main file name.+  mainFile <- if pkgType == Just Library then return Nothing else+                    getMainFile flags++  return $ flags { packageType = maybeToFlag pkgType+                 , 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, but will be created)") 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 if a test suite should be generated for the library.+getGenTests :: InitFlags -> IO InitFlags+getGenTests flags = do+  genTests <-     return (flagToMaybe $ initializeTestSuite flags)+                  -- Only generate a test suite if the package contains a library.+              ?>> if (packageType flags) == Flag Executable then return (Just False) else return Nothing+              ?>> maybePrompt flags+                  (promptYesNo+                    "Should I generate a test suite for the library"+                    (Just True))+  return $ flags { initializeTestSuite = maybeToFlag genTests }++-- | Ask for the test suite root directory.+getTestDir :: InitFlags -> IO InitFlags+getTestDir flags = do+  dirs <- return (testDirs flags)+              -- Only need testDirs when test suite generation is enabled.+          ?>> if not (eligibleForTestSuite flags) then return (Just []) else return Nothing+          ?>> fmap (fmap ((:[]) . either id id)) (maybePrompt+                   flags+                   (promptList "Test directory" ["test"] (Just "test") id True))++  return $ flags { testDirs = dirs }++-- | Ask for the Haskell base language of the package.+getLanguage :: InitFlags -> IO InitFlags+getLanguage flags = do+  lang <-     return (flagToMaybe $ language flags)+          ?>> maybePrompt flags+                (either UnknownLanguage id `fmap`+                  promptList "What base language is the package written in"+                  [Haskell2010, Haskell98]+                  (Just Haskell2010) prettyShow True)+          ?>> return (Just Haskell2010)++  if invalidLanguage lang+    then putStrLn invalidOtherLanguageMsg >> getLanguage flags+    else return $ flags { language = maybeToFlag lang }++  where+    invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t+    invalidLanguage _ = False++    invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " +++                              "Please enter a different language."++-- | Ask whether to generate explanatory comments.+getGenComments :: InitFlags -> IO InitFlags+getGenComments flags = do+  genComments <-     return (not <$> flagToMaybe (noComments flags))+                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))+                 ?>> return (Just False)+  return $ flags { noComments = maybeToFlag (fmap not genComments) }+  where+    promptMsg = "Add informative comments to each field in the cabal file (y/n)"++-- | Ask for the application root directory.+getAppDir :: InitFlags -> IO InitFlags+getAppDir flags = do+  appDirs <- noAppDirIfLibraryOnly+    ?>> guessAppDir flags+    ?>> promptUserForApplicationDir+    ?>> setDefault+  return $ flags { applicationDirs = appDirs }+  where+    -- If the packageType==Library, ignore defined appdir.+    noAppDirIfLibraryOnly :: IO (Maybe [String])+    noAppDirIfLibraryOnly+      | packageType flags == Flag Library = return $ Just []+      | otherwise = return $ applicationDirs flags++    -- Set the default application directory.+    setDefault :: IO (Maybe [String])+    setDefault = pure (Just [defaultApplicationDir])++    -- Prompt the user for the application directory (defaulting to "app").+    -- Returns 'Nothing' if in non-interactive mode, otherwise will always+    -- return a 'Just' value ('Just []' if no separate application directory).+    promptUserForApplicationDir :: IO (Maybe [String])+    promptUserForApplicationDir = fmap (either (:[]) id) <$> maybePrompt+      flags+      (promptList+       ("Application " ++ mainFile ++ "directory")+       [[defaultApplicationDir], ["src-exe"], []]+        (Just [defaultApplicationDir])+       showOption True)++    showOption :: [String] -> String+    showOption [] = "(none)"+    showOption (x:_) = x++    -- The name+    mainFile :: String+    mainFile = case mainIs flags of+      Flag mainPath -> "(" ++ mainPath ++ ") "+      _             -> ""++-- | Try to guess app directory. Could try harder; for the+--   moment just looks to see whether there is a directory called 'app'.+guessAppDir :: InitFlags -> IO (Maybe [String])+guessAppDir flags = do+  dir      <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  appIsDir <- doesDirectoryExist (dir </> "app")+  return $ if appIsDir+             then Just ["app"]+             else Nothing++-- | Ask for the source (library) root directory.+getSrcDir :: InitFlags -> IO InitFlags+getSrcDir flags = do+  srcDirs <- noSourceDirIfExecutableOnly+    ?>> guessSourceDir flags+    ?>> promptUserForSourceDir+    ?>> setDefault++  return $ flags { sourceDirs = srcDirs }++  where+    -- If the packageType==Executable, then ignore source dir+    noSourceDirIfExecutableOnly :: IO (Maybe [String])+    noSourceDirIfExecutableOnly+      | packageType flags == Flag Executable = return $ Just []+      | otherwise = return $ sourceDirs flags++    -- Set the default source directory.+    setDefault :: IO (Maybe [String])+    setDefault = pure (Just [defaultSourceDir])++    -- Prompt the user for the source directory (defaulting to "app").+    -- Returns 'Nothing' if in non-interactive mode, otherwise will always+    -- return a 'Just' value ('Just []' if no separate application directory).+    promptUserForSourceDir :: IO (Maybe [String])+    promptUserForSourceDir = fmap (either (:[]) id) <$> maybePrompt+      flags+      (promptList+       ("Library source directory")+       [[defaultSourceDir], ["lib"], ["src-lib"], []]+        (Just [defaultSourceDir])+       showOption True)++    showOption :: [String] -> String+    showOption [] = "(none)"+    showOption (x:_) = x+++-- | Try to guess source directory. Could try harder; for the+--   moment just looks to see whether there is a directory called 'src'.+guessSourceDir :: InitFlags -> IO (Maybe [String])+guessSourceDir flags = do+  dir      <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  srcIsDir <- doesDirectoryExist (dir </> "src")+  return $ if srcIsDir+             then Just ["src"]+             else Nothing++-- | Check whether a potential source file is located in one of the+--   source directories.+isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool+isSourceFile Nothing        sf = isSourceFile (Just ["."]) sf+isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs++-- | Get the list of exposed modules and extra tools needed to build them.+getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags+getModulesBuildToolsAndDeps pkgIx flags = do+  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags++  sourceFiles0 <- scanForModules dir++  let sourceFiles = filter (isSourceFile (sourceDirs flags)) sourceFiles0++  Just mods <-      return (exposedModules flags)+           ?>> (return . Just . map moduleName $ sourceFiles)++  tools <-     return (buildTools flags)+           ?>> (return . Just . neededBuildPrograms $ sourceFiles)++  deps <-      return (dependencies flags)+           ?>> Just <$> importsToDeps flags+                        (fromString "Prelude" :  -- to ensure we get base as a dep+                           (   nub   -- only need to consider each imported package once+                             . filter (`notElem` mods)  -- don't consider modules from+                                                        -- this package itself+                             . concatMap imports+                             $ sourceFiles+                           )+                        )+                        pkgIx++  exts <-     return (otherExts flags)+          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)++  -- If we're initializing a library and there were no modules discovered+  -- then create an empty 'MyLib' module.+  -- This gets a little tricky when 'sourceDirs' == 'applicationDirs' because+  -- then the executable needs to set 'other-modules: MyLib' or else the build+  -- fails.+  let (finalModsList, otherMods) = case (packageType flags, mods) of++        -- For an executable leave things as they are.+        (Flag Executable, _) -> (mods, otherModules flags)++        -- If a non-empty module list exists don't change anything.+        (_, (_:_)) -> (mods, otherModules flags)++        -- Library only: 'MyLib' in 'other-modules' only.+        (Flag Library, _) -> ([myLibModule], Nothing)++        -- For a 'LibraryAndExecutable' we need to have special handling.+        -- If we don't have a module list (Nothing or empty), then create a Lib.+        (_, []) ->+          if sourceDirs flags == applicationDirs flags+          then ([myLibModule], Just [myLibModule])+          else ([myLibModule], Nothing)++  return $ flags { exposedModules = Just finalModsList+                 , otherModules   = otherMods+                 , buildTools     = tools+                 , dependencies   = deps+                 , otherExts      = exts+                 }++-- | Given a list of imported modules, retrieve the list of dependencies that+-- provide those modules.+importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency]+importsToDeps flags mods pkgIx = do++  let modMap :: M.Map ModuleName [InstalledPackageInfo]+      modMap  = M.map (filter exposed) $ moduleNameIndex pkgIx++      modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]+      modDeps = map (id &&& flip M.lookup modMap) mods++  message flags "\nGuessing dependencies..."+  nub . catMaybes <$> traverse (chooseDep flags) modDeps++-- Given a module and a list of installed packages providing it,+-- choose a dependency (i.e. package + version range) to use for that+-- module.+chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])+          -> IO (Maybe P.Dependency)++chooseDep flags (m, Nothing)+  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")+    >> return Nothing++chooseDep flags (m, Just [])+  = message flags ("\nWarning: no package found providing " ++ prettyShow m ++ ".")+    >> return Nothing++    -- We found some packages: group them by name.+chooseDep flags (m, Just ps)+  = case pkgGroups of+      -- if there's only one group, i.e. multiple versions of a single package,+      -- we make it into a dependency, choosing the latest-ish version (see toDep).+      [grp] -> Just <$> toDep grp+      -- otherwise, we refuse to choose between different packages and make the user+      -- do it.+      grps  -> do message flags ("\nWarning: multiple packages found providing "+                                 ++ prettyShow m+                                 ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))+                  message flags "You will need to pick one and manually add it to the Build-depends: field."+                  return Nothing+  where+    pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps)++    desugar = maybe True (< CabalSpecV2_0) $ flagToMaybe (cabalVersion flags)++    -- Given a list of available versions of the same package, pick a dependency.+    toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency++    -- If only one version, easy.  We change e.g. 0.4.2  into  0.4.*+    toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) P.mainLibSet --TODO sublibraries++    -- Otherwise, choose the latest version and issue a warning.+    toDep pids  = do+      message flags ("\nWarning: multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")+      return $ P.Dependency (P.pkgName . NE.head $ pids)+                            (pvpize desugar . maximum . fmap P.pkgVersion $ pids)+                            P.mainLibSet --TODO take into account sublibraries++-- | Given a version, return an API-compatible (according to PVP) version range.+--+-- If the boolean argument denotes whether to use a desugared+-- representation (if 'True') or the new-style @^>=@-form (if+-- 'False').+--+-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the+-- same as @0.4.*@).+pvpize :: Bool -> Version -> VersionRange+pvpize False  v = majorBoundVersion v+pvpize True   v = orLaterVersion v'+           `intersectVersionRanges`+           earlierVersion (incVersion 1 v')+  where v' = alterVersion (take 2) v++-- | Increment the nth version component (counting from 0).+incVersion :: Int -> Version -> Version+incVersion n = alterVersion (incVersion' n)+  where+    incVersion' 0 []     = [1]+    incVersion' 0 (v:_)  = [v+1]+    incVersion' m []     = replicate m 0 ++ [1]+    incVersion' m (v:vs) = v : incVersion' (m-1) vs++-- | Generate warnings for missing fields etc.+generateWarnings :: InitFlags -> IO ()+generateWarnings flags = do+  message flags ""+  when (synopsis flags `elem` [NoFlag, Flag ""])+       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")++  message flags "You may want to edit the .cabal file and add a Description field."
+ src/Distribution/Client/Init/Defaults.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Defaults+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Default values to use in cabal init (if not specified in config/flags).+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Defaults (+    defaultApplicationDir+  , defaultSourceDir+  , defaultCabalVersion+  , myLibModule+  ) where++import Prelude (String)++import Distribution.ModuleName+  ( ModuleName )  -- And for the Text instance+import qualified Distribution.ModuleName as ModuleName+  ( fromString )+import Distribution.CabalSpecVersion+  ( CabalSpecVersion (..))++defaultApplicationDir :: String+defaultApplicationDir = "app"++defaultSourceDir :: String+defaultSourceDir = "src"++defaultCabalVersion :: CabalSpecVersion+defaultCabalVersion = CabalSpecV2_4++myLibModule :: ModuleName+myLibModule = ModuleName.fromString "MyLib"
+ src/Distribution/Client/Init/FileCreators.hs view
@@ -0,0 +1,651 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.FileCreators+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions to create files during 'cabal init'.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.FileCreators (++    -- * Commands+    writeLicense+  , writeChangeLog+  , createDirectories+  , createLibHs+  , createMainHs+  , createTestSuiteIfEligible+  , writeCabalFile++  -- * For testing+  , generateCabalFile+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)++import System.FilePath+  ( (</>), (<.>), takeExtension )++import Distribution.Types.Dependency+import Distribution.Types.VersionRange++import Data.Time+  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )+import System.Directory+  ( getCurrentDirectory, doesFileExist, copyFile+  , createDirectoryIfMissing )++import Text.PrettyPrint hiding ((<>), mode, cat)++import Distribution.Client.Init.Defaults+  ( defaultCabalVersion, myLibModule )+import Distribution.Client.Init.Licenses+  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )+import Distribution.Client.Init.Utils+  ( eligibleForTestSuite, message )+import Distribution.Client.Init.Types+  ( InitFlags(..), BuildType(..), PackageType(..) )++import Distribution.CabalSpecVersion+import Distribution.Compat.Newtype+  ( Newtype )+import Distribution.Fields.Field+  ( FieldName )+import Distribution.License+  ( licenseFromSPDX )+import qualified Distribution.ModuleName as ModuleName+  ( toFilePath )+import Distribution.FieldGrammar.Newtypes+  ( SpecVersion(..) )+import Distribution.PackageDescription.FieldGrammar+  ( formatDependencyList, formatExposedModules, formatHsSourceDirs,+    formatOtherExtensions, formatOtherModules, formatExtraSourceFiles )+import Distribution.Simple.Flag+  ( maybeToFlag )+import Distribution.Simple.Setup+  ( Flag(..), flagToMaybe )+import Distribution.Simple.Utils+  ( toUTF8BS )+import Distribution.Fields.Pretty+  ( PrettyField(..), showFields' )++import qualified Distribution.SPDX as SPDX++import Distribution.Utils.Path -- TODO++---------------------------------------------------------------------------+--  File generation  ------------------------------------------------------+---------------------------------------------------------------------------++-- | Write the LICENSE file, as specified in the InitFlags license field.+--+-- For licences that contain the author's name(s), the values are taken+-- from the 'authors' field of 'InitFlags', and if not specified will+-- be the string "???".+--+-- If the license type is unknown no license file will be created and+-- a warning will be raised.+writeLicense :: InitFlags -> IO ()+writeLicense flags = do+  message flags "\nGenerating LICENSE..."+  year <- show <$> getCurrentYear+  let authors = fromMaybe "???" . flagToMaybe . author $ flags+  let isSimpleLicense :: SPDX.License -> Maybe SPDX.LicenseId+      isSimpleLicense (SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)) = Just lid+      isSimpleLicense _                                                            = Nothing+  let licenseFile =+        case flagToMaybe (license flags) >>= isSimpleLicense of+          Just SPDX.BSD_2_Clause  -> Just $ bsd2 authors year+          Just SPDX.BSD_3_Clause  -> Just $ bsd3 authors year+          Just SPDX.Apache_2_0    -> Just apache20+          Just SPDX.MIT           -> Just $ mit authors year+          Just SPDX.MPL_2_0       -> Just mpl20+          Just SPDX.ISC           -> Just $ isc authors year++          -- GNU license come in "only" and "or-later" flavours+          -- license file used are the same.+          Just SPDX.GPL_2_0_only  -> Just gplv2+          Just SPDX.GPL_3_0_only  -> Just gplv3+          Just SPDX.LGPL_2_1_only -> Just lgpl21+          Just SPDX.LGPL_3_0_only -> Just lgpl3+          Just SPDX.AGPL_3_0_only -> Just agplv3++          Just SPDX.GPL_2_0_or_later  -> Just gplv2+          Just SPDX.GPL_3_0_or_later  -> Just gplv3+          Just SPDX.LGPL_2_1_or_later -> Just lgpl21+          Just SPDX.LGPL_3_0_or_later -> Just lgpl3+          Just SPDX.AGPL_3_0_or_later -> Just agplv3++          _ -> Nothing++  case licenseFile of+    Just licenseText -> writeFileSafe flags "LICENSE" licenseText+    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."++-- | Returns the current calendar year.+getCurrentYear :: IO Integer+getCurrentYear = do+  u <- getCurrentTime+  z <- getCurrentTimeZone+  let l = utcToLocalTime z u+      (y, _, _) = toGregorian $ localDay l+  return y++defaultChangeLog :: FilePath+defaultChangeLog = "CHANGELOG.md"++-- | Writes the changelog to the current directory.+writeChangeLog :: InitFlags -> IO ()+writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do+  message flags ("Generating "++ defaultChangeLog ++"...")+  writeFileSafe flags defaultChangeLog changeLog+ where+  changeLog = unlines+    [ "# Revision history for " ++ pname+    , ""+    , "## " ++ pver ++ " -- YYYY-mm-dd"+    , ""+    , "* First version. Released on an unsuspecting world."+    ]+  pname = maybe "" prettyShow $ flagToMaybe $ packageName flags+  pver = maybe "" prettyShow $ flagToMaybe $ version flags++-- | Creates and writes the initialized .cabal file.+--+-- Returns @False@ if no package name is specified, @True@ otherwise.+writeCabalFile :: InitFlags -> IO Bool+writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do+  message flags "Error: no package name provided."+  return False+writeCabalFile flags@(InitFlags{packageName = Flag p}) = do+  let cabalFileName = prettyShow p ++ ".cabal"+  message flags $ "Generating " ++ cabalFileName ++ "..."+  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)+  return True++-- | Write a file \"safely\", backing up any existing version (unless+--   the overwrite flag is set).+writeFileSafe :: InitFlags -> FilePath -> String -> IO ()+writeFileSafe flags fileName content = do+  moveExistingFile flags fileName+  writeFile fileName content++-- | Create directories, if they were given, and don't already exist.+createDirectories :: Maybe [String] -> IO ()+createDirectories mdirs = case mdirs of+  Just dirs -> for_ dirs (createDirectoryIfMissing True)+  Nothing   -> return ()++-- | Create MyLib.hs file, if its the only module in the liste.+createLibHs :: InitFlags -> IO ()+createLibHs flags = when ((exposedModules flags) == Just [myLibModule]) $ do+  let modFilePath = ModuleName.toFilePath myLibModule ++ ".hs"+  case sourceDirs flags of+    Just (srcPath:_) -> writeLibHs flags (srcPath </> modFilePath)+    _                -> writeLibHs flags modFilePath++-- | Write a MyLib.hs file if it doesn't already exist.+writeLibHs :: InitFlags -> FilePath -> IO ()+writeLibHs flags libPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let libFullPath = dir </> libPath+  exists <- doesFileExist libFullPath+  unless exists $ do+    message flags $ "Generating " ++ libPath ++ "..."+    writeFileSafe flags libFullPath myLibHs++-- | Default MyLib.hs file.  Used when no Lib.hs exists.+myLibHs :: String+myLibHs = unlines+  [ "module MyLib (someFunc) where"+  , ""+  , "someFunc :: IO ()"+  , "someFunc = putStrLn \"someFunc\""+  ]++-- | Create Main.hs, but only if we are init'ing an executable and+--   the mainIs flag has been provided.+createMainHs :: InitFlags -> IO ()+createMainHs flags =+  if hasMainHs flags then+    case applicationDirs flags of+      Just (appPath:_) -> writeMainHs flags (appPath </> mainFile)+      _ -> writeMainHs flags mainFile+  else return ()+  where+    mainFile = case mainIs flags of+      Flag x -> x+      NoFlag -> error "createMainHs: no mainIs"++-- | Write a main file if it doesn't already exist.+writeMainHs :: InitFlags -> FilePath -> IO ()+writeMainHs flags mainPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let mainFullPath = dir </> mainPath+  exists <- doesFileExist mainFullPath+  unless exists $ do+      message flags $ "Generating " ++ mainPath ++ "..."+      writeFileSafe flags mainFullPath (mainHs flags)++-- | Returns true if a main file exists.+hasMainHs :: InitFlags -> Bool+hasMainHs flags = case mainIs flags of+  Flag _ -> (packageType flags == Flag Executable+             || packageType flags == Flag LibraryAndExecutable)+  _ -> False++-- | Default Main.(l)hs file.  Used when no Main.(l)hs exists.+--+--   If we are initializing a new 'LibraryAndExecutable' then import 'MyLib'.+mainHs :: InitFlags -> String+mainHs flags = (unlines . map prependPrefix) $ case packageType flags of+  Flag LibraryAndExecutable ->+    [ "module Main where"+    , ""+    , "import qualified MyLib (someFunc)"+    , ""+    , "main :: IO ()"+    , "main = do"+    , "  putStrLn \"Hello, Haskell!\""+    , "  MyLib.someFunc"+    ]+  _ ->+    [ "module Main where"+    , ""+    , "main :: IO ()"+    , "main = putStrLn \"Hello, Haskell!\""+    ]+  where+    prependPrefix :: String -> String+    prependPrefix "" = ""+    prependPrefix line+      | isLiterate = "> " ++ line+      | otherwise  = line+    isLiterate = case mainIs flags of+      Flag mainPath -> takeExtension mainPath == ".lhs"+      _             -> False++-- | Create a test suite for the package if eligible.+createTestSuiteIfEligible :: InitFlags -> IO ()+createTestSuiteIfEligible flags =+  when (eligibleForTestSuite flags) $ do+    createDirectories (testDirs flags)+    createTestHs flags++-- | The name of the test file to generate (if --tests is specified).+testFile :: String+testFile = "MyLibTest.hs"++-- | Create MyLibTest.hs, but only if we are init'ing a library and+--   the initializeTestSuite flag has been set.+--+-- It is up to the caller to verify that the package is eligible+-- for test suite initialization (see eligibleForTestSuite).+createTestHs :: InitFlags -> IO ()+createTestHs flags =+  case testDirs flags of+    Just (testPath:_) -> writeTestHs flags (testPath </> testFile)+    _ -> writeMainHs flags testFile++-- | Write a test file.+writeTestHs :: InitFlags -> FilePath -> IO ()+writeTestHs flags testPath = do+  dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  let testFullPath = dir </> testPath+  exists <- doesFileExist testFullPath+  unless exists $ do+      message flags $ "Generating " ++ testPath ++ "..."+      writeFileSafe flags testFullPath testHs++-- | Default MyLibTest.hs file.+testHs :: String+testHs = unlines+  [ "module Main (main) where"+  , ""+  , "main :: IO ()"+  , "main = putStrLn \"Test suite not yet implemented.\""+  ]+++-- | Move an existing file, if there is one, and the overwrite flag is+--   not set.+moveExistingFile :: InitFlags -> FilePath -> IO ()+moveExistingFile flags fileName =+  unless (overwrite flags == Flag True) $ do+    e <- doesFileExist fileName+    when e $ do+      newName <- findNewName fileName+      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName+      copyFile fileName newName+++-- | Given a file path find a new name for the file that does not+--   already exist.+findNewName :: FilePath -> IO FilePath+findNewName oldName = findNewName' 0+  where+    findNewName' :: Integer -> IO FilePath+    findNewName' n = do+      let newName = oldName <.> ("save" ++ show n)+      e <- doesFileExist newName+      if e then findNewName' (n+1) else return newName+++-- | Generate a .cabal file from an InitFlags structure.+generateCabalFile :: String -> InitFlags -> String+generateCabalFile fileName c =+    showFields' annCommentLines postProcessFieldLines 4 $ catMaybes+  [ fieldP "cabal-version" (Flag . SpecVersion $ specVer)+      []+      False++  , field "name" (packageName c)+      ["Initial package description '" ++ fileName ++ "' generated by",+       "'cabal init'. For further documentation, see:",+       "  http://haskell.org/cabal/users-guide/",+       "",+       "The name of the package."]+      True++  , field  "version"       (version       c)+           ["The package version.",+            "See the Haskell package versioning policy (PVP) for standards",+            "guiding when and how versions should be incremented.",+            "https://pvp.haskell.org",+            "PVP summary:      +-+------- breaking API changes",+            "                  | | +----- non-breaking API additions",+            "                  | | | +--- code changes with no API change"]+           True++  , fieldS "synopsis"      (synopsis      c)+           ["A short (one-line) description of the package."]+           True++  , fieldS "description"   NoFlag+           ["A longer description of the package."]+           True++  , fieldS "homepage"      (homepage     c)+           ["URL for the project homepage or repository."]+           False++  , fieldS "bug-reports"   NoFlag+           ["A URL where users can report bugs."]+           True++  , fieldS  "license"      licenseStr+                ["The license under which the package is released."]+                True++  , case license c of+      NoFlag         -> Nothing+      Flag SPDX.NONE -> Nothing+      _ -> fieldS "license-file" (Flag "LICENSE")+                  ["The file containing the license text."]+                  True++  , fieldS "author"        (author       c)+           ["The package author(s)."]+           True++  , fieldS "maintainer"    (email        c)+           ["An email address to which users can send suggestions, bug reports, and patches."]+           True++  , fieldS "copyright"     NoFlag+           ["A copyright notice."]+           True++  , fieldS "category"      (either id prettyShow `fmap` category c)+           []+           True++  , fieldS "build-type"    (if specVer >= CabalSpecV2_2 then NoFlag else Flag "Simple")+           []+           False++  , fieldPAla "extra-source-files" formatExtraSourceFiles (maybeToFlag (extraSrc c))+           ["Extra files to be distributed with the package, such as examples or a README."]+           True+  ]+  +++  (case packageType c of+     Flag Executable -> [executableStanza]+     Flag Library    -> [libraryStanza]+     Flag LibraryAndExecutable -> [libraryStanza, executableStanza]+     _               -> [])+  +++  if eligibleForTestSuite c then [testSuiteStanza] else []++ where+   specVer :: CabalSpecVersion+   specVer = fromMaybe defaultCabalVersion $ flagToMaybe (cabalVersion c)++   licenseStr | specVer < CabalSpecV2_2 = prettyShow . licenseFromSPDX <$> license c+              | otherwise               = prettyShow                   <$> license c++   generateBuildInfo :: BuildType -> InitFlags -> [PrettyField FieldAnnotation]+   generateBuildInfo buildType c' = catMaybes+     [ fieldPAla "other-modules" formatOtherModules (maybeToFlag otherMods)+       [ case buildType of+                 LibBuild    -> "Modules included in this library but not exported."+                 ExecBuild -> "Modules included in this executable, other than Main."]+       True++     , fieldPAla "other-extensions" formatOtherExtensions (maybeToFlag (otherExts c))+       ["LANGUAGE extensions used by modules in this package."]+       True++     , fieldPAla "build-depends" formatDependencyList (maybeToFlag buildDependencies)+       ["Other library packages from which modules are imported."]+       True++     , fieldPAla "hs-source-dirs" formatHsSourceDirs+       (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ case buildType of+         LibBuild -> sourceDirs c+         ExecBuild -> applicationDirs c)+       ["Directories containing source files."]+       True++     , fieldS "build-tools" (listFieldS $ buildTools c)+       ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]+       False++     , field "default-language" (language c)+       ["Base language which the package is written in."]+       True+     ]+     -- Hack: Can't construct a 'Dependency' which is just 'packageName'(?).+     where+       buildDependencies :: Maybe [Dependency]+       buildDependencies = (++ myLibDep) <$> dependencies c'++       myLibDep :: [Dependency]+       myLibDep = if exposedModules c' == Just [myLibModule] && buildType == ExecBuild+                      then case packageName c' of+                             Flag pkgName ->+                               [mkDependency pkgName anyVersion mainLibSet]+                             _ -> []+                  else []++       -- Only include 'MyLib' in 'other-modules' of the executable.+       otherModsFromFlag = otherModules c'+       otherMods = if buildType == LibBuild && otherModsFromFlag == Just [myLibModule]+                   then Nothing+                   else otherModsFromFlag++   listFieldS :: Maybe [String] -> Flag String+   listFieldS Nothing = NoFlag+   listFieldS (Just []) = NoFlag+   listFieldS (Just xs) = Flag . intercalate ", " $ xs++   -- | Construct a 'PrettyField' from a field that can be automatically+   --   converted to a 'Doc' via 'display'.+   field :: Pretty t+         => FieldName+         -> Flag t+         -> [String]+         -> Bool+         -> Maybe (PrettyField FieldAnnotation)+   field fieldName fieldContentsFlag = fieldS fieldName (prettyShow <$> fieldContentsFlag)++   -- | Construct a 'PrettyField' from a 'String' field.+   fieldS :: FieldName   -- ^ Name of the field+          -> Flag String -- ^ Field contents+          -> [String]    -- ^ Comment to explain the field+          -> Bool        -- ^ Should the field be included (commented out) even if blank?+          -> Maybe (PrettyField FieldAnnotation)+   fieldS fieldName fieldContentsFlag = fieldD fieldName (text <$> fieldContentsFlag)++   -- | Construct a 'PrettyField' from a Flag which can be 'pretty'-ied.+   fieldP :: Pretty a+          => FieldName+          -> Flag a+          -> [String]+          -> Bool+          -> Maybe (PrettyField FieldAnnotation)+   fieldP fieldName fieldContentsFlag fieldComments includeField =+     fieldPAla fieldName Identity fieldContentsFlag fieldComments includeField++   -- | Construct a 'PrettyField' from a flag which can be 'pretty'-ied, wrapped in newtypeWrapper.+   fieldPAla+     :: (Pretty b, Newtype a b)+     => FieldName+     -> (a -> b)+     -> Flag a+     -> [String]+     -> Bool+     -> Maybe (PrettyField FieldAnnotation)+   fieldPAla fieldName newtypeWrapper fieldContentsFlag fieldComments includeField =+     fieldD fieldName (pretty . newtypeWrapper <$> fieldContentsFlag) fieldComments includeField++   -- | Construct a 'PrettyField' from a 'Doc' Flag.+   fieldD :: FieldName   -- ^ Name of the field+          -> Flag Doc    -- ^ Field contents+          -> [String]    -- ^ Comment to explain the field+          -> Bool        -- ^ Should the field be included (commented out) even if blank?+          -> Maybe (PrettyField FieldAnnotation)+   fieldD fieldName fieldContentsFlag fieldComments includeField =+     case fieldContentsFlag of+       NoFlag ->+         -- If there is no content, optionally produce a commented out field.+         fieldSEmptyContents fieldName fieldComments includeField++       Flag fieldContents ->+         if isEmpty fieldContents+         then+           -- If the doc is empty, optionally produce a commented out field.+           fieldSEmptyContents fieldName fieldComments includeField+         else+           -- If the doc is not empty, produce a field.+           Just $ case (noComments c, minimal c) of+             -- If the "--no-comments" flag is set, strip comments.+             (Flag True, _) ->+               fieldSWithContents fieldName fieldContents []+             -- If the "--minimal" flag is set, strip comments.+             (_, Flag True) ->+               fieldSWithContents fieldName fieldContents []+             -- Otherwise, include comments.+             (_, _) ->+               fieldSWithContents fieldName fieldContents fieldComments++   -- | Optionally produce a field with no content (depending on flags).+   fieldSEmptyContents :: FieldName+                       -> [String]+                       -> Bool+                       -> Maybe (PrettyField FieldAnnotation)+   fieldSEmptyContents fieldName fieldComments includeField+     | not includeField || (minimal c == Flag True) =+         Nothing+     | otherwise =+         Just (PrettyField (commentedOutWithComments fieldComments) fieldName empty)++   -- | Produce a field with content.+   fieldSWithContents :: FieldName+                      -> Doc+                      -> [String]+                      -> PrettyField FieldAnnotation+   fieldSWithContents fieldName fieldContents fieldComments =+     PrettyField (withComments (map ("-- " ++) fieldComments)) fieldName fieldContents++   executableStanza :: PrettyField FieldAnnotation+   executableStanza = PrettySection annNoComments (toUTF8BS "executable") [exeName] $ catMaybes+     [ fieldS "main-is" (mainIs c)+       [".hs or .lhs file containing the Main module."]+       True+     ]+     +++     generateBuildInfo ExecBuild c+     where+       exeName = text (maybe "" prettyShow . flagToMaybe $ packageName c)++   libraryStanza :: PrettyField FieldAnnotation+   libraryStanza = PrettySection annNoComments (toUTF8BS "library") [] $ catMaybes+     [ fieldPAla "exposed-modules" formatExposedModules (maybeToFlag (exposedModules c))+       ["Modules exported by the library."]+       True+     ]+     +++     generateBuildInfo LibBuild c+++   testSuiteStanza :: PrettyField FieldAnnotation+   testSuiteStanza = PrettySection annNoComments (toUTF8BS "test-suite") [testSuiteName] $ catMaybes+     [ field "default-language" (language c)+       ["Base language which the package is written in."]+       True++     , fieldS "type" (Flag "exitcode-stdio-1.0")+       ["The interface type and version of the test suite."]+       True++     , fieldPAla "hs-source-dirs" formatHsSourceDirs+       (maybeToFlag $ fmap (fmap unsafeMakeSymbolicPath) $ testDirs c) -- TODO+       ["Directories containing source files."]+       True++     , fieldS "main-is" (Flag testFile)+       ["The entrypoint to the test suite."]+       True++     , fieldPAla  "build-depends" formatDependencyList (maybeToFlag (dependencies c))+       ["Test dependencies."]+       True+     ]+     where+       testSuiteName =+         text (maybe "" ((++"-test") . prettyShow) . flagToMaybe $ packageName c)++-- | Annotations for cabal file PrettyField.+data FieldAnnotation = FieldAnnotation+  { annCommentedOut :: Bool+    -- ^ True iif the field and its contents should be commented out.+  , annCommentLines :: [String]+    -- ^ Comment lines to place before the field or section.+  }++-- | A field annotation instructing the pretty printer to comment out the field+--   and any contents, with no comments.+commentedOutWithComments :: [String] -> FieldAnnotation+commentedOutWithComments = FieldAnnotation True . map ("-- " ++)++-- | A field annotation with the specified comment lines.+withComments :: [String] -> FieldAnnotation+withComments = FieldAnnotation False++-- | A field annotation with no comments.+annNoComments :: FieldAnnotation+annNoComments = FieldAnnotation False []++postProcessFieldLines :: FieldAnnotation -> [String] -> [String]+postProcessFieldLines ann+  | annCommentedOut ann = map ("-- " ++)+  | otherwise = id
+ src/Distribution/Client/Init/Heuristics.hs view
@@ -0,0 +1,396 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Heuristics+-- Copyright   :  (c) Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Heuristics for creating initial cabal files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Heuristics (+    guessPackageName,+    scanForModules,     SourceFileEntry(..),+    neededBuildPrograms,+    guessMainFileCandidates,+    guessAuthorNameMail,+    knownCategories,+) where++import Prelude ()+import qualified Data.ByteString as BS+import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic (safeHead, safeTail, safeLast)++import Distribution.Simple.Setup (Flag(..), flagToMaybe)+import Distribution.Simple.Utils (fromUTF8BS)+import Distribution.ModuleName+    ( ModuleName, toFilePath )+import qualified Distribution.Package as P+import qualified Distribution.PackageDescription as PD+    ( category, packageDescription )+import Distribution.Client.Utils+         ( tryCanonicalizePath )+import Language.Haskell.Extension ( Extension )++import Distribution.Solver.Types.PackageIndex+    ( allPackagesByName )+import Distribution.Solver.Types.SourcePackage+    ( srcpkgDescription )++import Distribution.Client.Types ( SourcePackageDb(..) )+import Data.Char   ( isLower )+import Data.List   ( isInfixOf )+import qualified Data.Set as Set ( fromList, toList )+import System.Directory ( getCurrentDirectory, getDirectoryContents,+                          doesDirectoryExist, doesFileExist, getHomeDirectory, )+import Distribution.Compat.Environment ( getEnvironment )+import System.FilePath ( takeExtension, takeBaseName, dropExtension,+                         (</>), (<.>), splitDirectories, makeRelative )++import Distribution.Client.Init.Types     ( InitFlags(..) )+import Distribution.Client.Compat.Process ( readProcessWithExitCode )++import qualified Distribution.Utils.ShortText as ShortText++-- | Return a list of candidate main files for this executable: top-level+-- modules including the word 'Main' in the file name. The list is sorted in+-- order of preference, shorter file names are preferred. 'Right's are existing+-- 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.mkPackageName . repair . fromMaybe "" . safeLast . 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 isDigit c = invalid c+                          | otherwise     = valid c+    repairRest = repair' id ('-' :)++-- |Data type of source files found in the working directory+data SourceFileEntry = SourceFileEntry+    { relativeSourcePath :: FilePath+    , moduleName         :: ModuleName+    , fileExtension      :: String+    , imports            :: [ModuleName]+    , extensions         :: [Extension]+    } deriving Show++sfToFileName :: FilePath -> SourceFileEntry -> FilePath+sfToFileName projectRoot (SourceFileEntry relPath m ext _ _)+  = projectRoot </> relPath </> toFilePath m <.> ext++-- |Search for source files in the given directory+-- and return pairs of guessed Haskell source path and+-- module names.+scanForModules :: FilePath -> IO [SourceFileEntry]+scanForModules rootDir = scanForModulesIn rootDir rootDir++scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry]+scanForModulesIn projectRoot srcRoot = scan srcRoot []+  where+    scan dir hierarchy = do+        entries <- getDirectoryContents (projectRoot </> dir)+        (files, dirs) <- liftM partitionEithers (traverse (tagIsDir dir) entries)+        let modules = catMaybes [ guessModuleName hierarchy file+                                | file <- files+                                , maybe False isUpper (safeHead file) ]+        modules' <- traverse (findImportsAndExts projectRoot) modules+        recMods <- traverse (scanRecursive dir hierarchy) dirs+        return $ concat (modules' : recMods)+    tagIsDir parent entry = do+        isDir <- doesDirectoryExist (parent </> entry)+        return $ (if isDir then Right else Left) entry+    guessModuleName hierarchy entry+        | takeBaseName entry == "Setup" = Nothing+        | ext `elem` sourceExtensions   =+            SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure []+        | otherwise = Nothing+      where+        relRoot       = makeRelative projectRoot srcRoot+        unqualModName = dropExtension entry+        modName       = simpleParsec+                      $ intercalate "." . reverse $ (unqualModName : hierarchy)+        ext           = case takeExtension entry of '.':e -> e; e -> e+    scanRecursive parent hierarchy entry+      | maybe False isUpper (safeHead entry) = scan (parent </> entry) (entry : hierarchy)+      | maybe False isLower (safeHead entry) && not (ignoreDir entry) =+          scanForModulesIn projectRoot $ foldl (</>) srcRoot (reverse (entry : hierarchy))+      | otherwise = return []+    ignoreDir ('.':_)  = True+    ignoreDir dir      = dir `elem` ["dist", "_darcs"]++-- | Read the contents of the handle and parse for Language pragmas+-- and other module names that might be part of this project.+findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry+findImportsAndExts projectRoot sf = do+  s <- fromUTF8BS <$> BS.readFile (sfToFileName projectRoot sf)++  let modules = mapMaybe+                ( getModName+                . drop 1+                . filter (not . null)+                . dropWhile (/= "import")+                . words+                )+              . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering+              . lines+              $ s++      -- TODO: We should probably make a better attempt at parsing+      -- comments above.  Unfortunately we can't use a full-fledged+      -- Haskell parser since cabal's dependencies must be kept at a+      -- minimum.++      -- A poor man's LANGUAGE pragma parser.+      exts = mapMaybe simpleParsec+           . concatMap getPragmas+           . filter isLANGUAGEPragma+           . map fst+           . drop 1+           . takeWhile (not . null . snd)+           . iterate (takeBraces . snd)+           $ ("",s)++      takeBraces = break (== '}') . dropWhile (/= '{')++      isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`)++      getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13++      splitCommas "" = []+      splitCommas xs = x : splitCommas (drop 1 y)+        where (x,y) = break (==',') xs++  return sf { imports    = modules+            , extensions = exts+            }++ where getModName :: [String] -> Maybe ModuleName+       getModName []               = Nothing+       getModName ("qualified":ws) = getModName ws+       getModName (ms:_)           = simpleParsec ms++++-- Unfortunately we cannot use the version exported by Distribution.Simple.Program+knownSuffixHandlers :: [(String,String)]+knownSuffixHandlers =+  [ ("gc",     "greencard")+  , ("chs",    "chs")+  , ("hsc",    "hsc2hs")+  , ("x",      "alex")+  , ("y",      "happy")+  , ("ly",     "happy")+  , ("cpphs",  "cpp")+  ]++sourceExtensions :: [String]+sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers++neededBuildPrograms :: [SourceFileEntry] -> [String]+neededBuildPrograms entries =+    [ handler+    | ext <- nubSet (map fileExtension entries)+    , handler <- maybeToList (lookup ext knownSuffixHandlers)+    ]++-- | Guess author and email using darcs and git configuration options. Use+-- the following in decreasing order of preference:+--+-- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*)+-- 2. Local repo configs+-- 3. Global vcs configs+-- 4. The generic $EMAIL+--+-- Name and email are processed separately, so the guess might end up being+-- a name from DARCS_EMAIL and an email from git config.+--+-- Darcs has preference, for tradition's sake.+guessAuthorNameMail :: IO (Flag String, Flag String)+guessAuthorNameMail = fmap authorGuessPure authorGuessIO++-- Ordered in increasing preference, since Flag-as-monoid is identical to+-- Last.+authorGuessPure :: AuthorGuessIO -> AuthorGuess+authorGuessPure (AuthorGuessIO { authorGuessEnv = env+                               , authorGuessLocalDarcs = darcsLocalF+                               , authorGuessGlobalDarcs = darcsGlobalF+                               , authorGuessLocalGit = gitLocal+                               , authorGuessGlobalGit = gitGlobal })+    = mconcat+        [ emailEnv env+        , gitGlobal+        , darcsCfg darcsGlobalF+        , gitLocal+        , darcsCfg darcsLocalF+        , gitEnv env+        , darcsEnv env+        ]++authorGuessIO :: IO AuthorGuessIO+authorGuessIO = AuthorGuessIO+    <$> getEnvironment+    <*> (maybeReadFile $ "_darcs" </> "prefs" </> "author")+    <*> (maybeReadFile =<< liftM (</> (".darcs" </> "author")) getHomeDirectory)+    <*> gitCfg Local+    <*> gitCfg Global++-- Types and functions used for guessing the author are now defined:++type AuthorGuess   = (Flag String, Flag String)+type Enviro        = [(String, String)]+data GitLoc        = Local | Global+data AuthorGuessIO = AuthorGuessIO {+    authorGuessEnv         :: Enviro,         -- ^ Environment lookup table+    authorGuessLocalDarcs  :: (Maybe String), -- ^ Contents of local darcs author info+    authorGuessGlobalDarcs :: (Maybe String), -- ^ Contents of global darcs author info+    authorGuessLocalGit    :: AuthorGuess,   -- ^ Git config --local+    authorGuessGlobalGit   :: AuthorGuess    -- ^ Git config --global+  }++darcsEnv :: Enviro -> AuthorGuess+darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"++gitEnv :: Enviro -> AuthorGuess+gitEnv env = (name, mail)+  where+    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, mail)+  where+    mail = maybeFlag "EMAIL" env++gitCfg :: GitLoc -> IO AuthorGuess+gitCfg which = do+  name <- gitVar which "user.name"+  mail <- gitVar which "user.email"+  return (name, mail)++gitVar :: GitLoc -> String -> IO (Flag String)+gitVar which = fmap happyOutput . gitConfigQuery which++happyOutput :: (ExitCode, a, t) -> Flag a+happyOutput v = case v of+  (ExitSuccess, s, _) -> Flag s+  _                   -> mempty++gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String)+gitConfigQuery which key =+    fmap trim' $ readProcessWithExitCode "git" ["config", w, key] ""+  where+    w = case which of+        Local  -> "--local"+        Global -> "--global"+    trim' (a, b, c) = (a, trim b, c)++maybeFlag :: String -> Enviro -> Flag String+maybeFlag k = maybe mempty Flag . lookup k++-- | Read the first non-comment, non-trivial line of a file, if it exists+maybeReadFile :: String -> IO (Maybe String)+maybeReadFile f = do+    exists <- doesFileExist f+    if exists+        then fmap getFirstLine $ readFile f+        else return Nothing+  where+    getFirstLine content =+      let nontrivialLines = dropWhile (\l -> (null l) || ("#" `isPrefixOf` l)) . lines $ content+      in case nontrivialLines of+           [] -> Nothing+           (l:_) -> Just l++-- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached+knownCategories :: SourcePackageDb -> [String]+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet+    [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex)+          , let catList = (PD.category . PD.packageDescription . srcpkgDescription) pkg+          , cat <- splitString ',' $ ShortText.fromShortText catList+    ]++-- Parse name and email, from darcs pref files or environment variable+nameAndMail :: String -> (Flag String, Flag String)+nameAndMail str+  | all isSpace nameOrEmail = mempty+  | null erest = (mempty, Flag $ trim nameOrEmail)+  | otherwise  = (Flag $ trim nameOrEmail, Flag mail)+  where+    (nameOrEmail,erest) = break (== '<') str+    (mail,_)            = break (== '>') (safeTail erest)++trim :: String -> String+trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse+  where+    removeLeadingSpace  = dropWhile isSpace++-- 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+      s' = dropWhile (\c -> c == sep || isSpace c) s+      (tok,rest) = break (==sep) s'++nubSet :: (Ord a) => [a] -> [a]+nubSet = Set.toList . Set.fromList++{-+test db testProjectRoot = do+  putStrLn "Guessed package name"+  (guessPackageName >=> print) testProjectRoot+  putStrLn "Guessed name and email"+  guessAuthorNameMail >>= print++  mods <- scanForModules testProjectRoot++  putStrLn "Guessed modules"+  mapM_ print mods+  putStrLn "Needed build programs"+  print (neededBuildPrograms mods)++  putStrLn "List of known categories"+  print $ knownCategories db+-}
+ src/Distribution/Client/Init/Licenses.hs view
@@ -0,0 +1,3077 @@+{-|+Module        :  Distribution.Client.Init.Licenses++Description   :  Factory functions for producing known license types.++License       :  BSD-like+Maintainer    :  cabal-devel@haskell.org+Stability     :  provisional+Portability   :  portable+-}+module Distribution.Client.Init.Licenses+  ( License+  , bsd2+  , bsd3+  , gplv2+  , gplv3+  , lgpl21+  , lgpl3+  , agplv3+  , apache20+  , mit+  , mpl20+  , isc+  ) where++import Prelude (String, unlines, (++))++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+    , ""+    , "All rights reserved."+    , ""+    , "Redistribution and use in source and binary forms, with or without"+    , "modification, are permitted provided that the following conditions are met:"+    , ""+    , "    * Redistributions of source code must retain the above copyright"+    , "      notice, this list of conditions and the following disclaimer."+    , ""+    , "    * 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."+    , ""+    , "    * Neither the name of " ++ authors ++ " nor the names of other"+    , "      contributors may be used to endorse or promote products derived"+    , "      from this software without specific prior written permission."+    , ""+    , "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."+    ]++gplv2 :: License+gplv2 = unlines+    [ "             GNU GENERAL PUBLIC LICENSE"+    , "                Version 2, June 1991"+    , ""+    , " Copyright (C) 1989, 1991 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."+    , ""+    , "                     Preamble"+    , ""+    , "  The licenses for most software are designed to take away your"+    , "freedom to share and change it.  By contrast, the GNU General Public"+    , "License is intended to guarantee your freedom to share and change free"+    , "software--to make sure the software is free for all its users.  This"+    , "General Public License applies to most of the Free Software"+    , "Foundation's software and to any other program whose authors commit to"+    , "using it.  (Some other Free Software Foundation software is covered by"+    , "the GNU Lesser General Public License instead.)  You can apply it to"+    , "your programs, too."+    , ""+    , "  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."+    , ""+    , "  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 software, or if you modify it."+    , ""+    , "  For example, if you distribute copies of such a program, whether"+    , "gratis or for a fee, you must give the recipients all the rights that"+    , "you have.  You must make sure that they, too, receive or can get the"+    , "source code.  And you must show them these terms so they know their"+    , "rights."+    , ""+    , "  We protect your rights with two steps: (1) copyright the software, and"+    , "(2) offer you this license which gives you legal permission to copy,"+    , "distribute and/or modify the software."+    , ""+    , "  Also, for each author's protection and ours, we want to make certain"+    , "that everyone understands that there is no warranty for this free"+    , "software.  If the software is modified by someone else and passed on, we"+    , "want its recipients to know that what they have is not the original, so"+    , "that any problems introduced by others will not reflect on the original"+    , "authors' reputations."+    , ""+    , "  Finally, any free program is threatened constantly by software"+    , "patents.  We wish to avoid the danger that redistributors of a free"+    , "program will individually obtain patent licenses, in effect making the"+    , "program proprietary.  To prevent this, we have made it clear that any"+    , "patent must be licensed for everyone's free use or not licensed at all."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "             GNU GENERAL PUBLIC LICENSE"+    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+    , ""+    , "  0. This License applies to any program or other work which contains"+    , "a notice placed by the copyright holder saying it may be distributed"+    , "under the terms of this General Public License.  The \"Program\", below,"+    , "refers to any such program or work, and a \"work based on the Program\""+    , "means either the Program or any derivative work under copyright law:"+    , "that is to say, a work containing the Program or a portion of it,"+    , "either verbatim or with modifications and/or translated into another"+    , "language.  (Hereinafter, translation is included without limitation in"+    , "the term \"modification\".)  Each licensee is addressed as \"you\"."+    , ""+    , "Activities other than copying, distribution and modification are not"+    , "covered by this License; they are outside its scope.  The act of"+    , "running the Program is not restricted, and the output from the Program"+    , "is covered only if its contents constitute a work based on the"+    , "Program (independent of having been made by running the Program)."+    , "Whether that is true depends on what the Program does."+    , ""+    , "  1. You may copy and distribute verbatim copies of the Program's"+    , "source code as you receive it, in any medium, provided that you"+    , "conspicuously and appropriately publish on each copy an appropriate"+    , "copyright notice and disclaimer of warranty; keep intact all the"+    , "notices that refer to this License and to the absence of any warranty;"+    , "and give any other recipients of the Program a copy of this License"+    , "along with the Program."+    , ""+    , "You may charge a fee for the physical act of transferring a copy, and"+    , "you may at your option offer warranty protection in exchange for a fee."+    , ""+    , "  2. You may modify your copy or copies of the Program or any portion"+    , "of it, thus forming a work based on the Program, and copy and"+    , "distribute such modifications or work under the terms of Section 1"+    , "above, provided that you also meet all of these conditions:"+    , ""+    , "    a) You must cause the modified files to carry prominent notices"+    , "    stating that you changed the files and the date of any change."+    , ""+    , "    b) You must cause any work that you distribute or publish, that in"+    , "    whole or in part contains or is derived from the Program or any"+    , "    part thereof, to be licensed as a whole at no charge to all third"+    , "    parties under the terms of this License."+    , ""+    , "    c) If the modified program normally reads commands interactively"+    , "    when run, you must cause it, when started running for such"+    , "    interactive use in the most ordinary way, to print or display an"+    , "    announcement including an appropriate copyright notice and a"+    , "    notice that there is no warranty (or else, saying that you provide"+    , "    a warranty) and that users may redistribute the program under"+    , "    these conditions, and telling the user how to view a copy of this"+    , "    License.  (Exception: if the Program itself is interactive but"+    , "    does not normally print such an announcement, your work based on"+    , "    the Program is not required to print an announcement.)"+    , ""+    , "These requirements apply to the modified work as a whole.  If"+    , "identifiable sections of that work are not derived from the Program,"+    , "and can be reasonably considered independent and separate works in"+    , "themselves, then this License, and its terms, do not apply to those"+    , "sections when you distribute them as separate works.  But when you"+    , "distribute the same sections as part of a whole which is a work based"+    , "on the Program, the distribution of the whole must be on the terms of"+    , "this License, whose permissions for other licensees extend to the"+    , "entire whole, and thus to each and every part regardless of who wrote it."+    , ""+    , "Thus, it is not the intent of this section to claim rights or contest"+    , "your rights to work written entirely by you; rather, the intent is to"+    , "exercise the right to control the distribution of derivative or"+    , "collective works based on the Program."+    , ""+    , "In addition, mere aggregation of another work not based on the Program"+    , "with the Program (or with a work based on the Program) on a volume of"+    , "a storage or distribution medium does not bring the other work under"+    , "the scope of this License."+    , ""+    , "  3. You may copy and distribute the Program (or a work based on it,"+    , "under Section 2) in object code or executable form under the terms of"+    , "Sections 1 and 2 above provided that you also do one of the following:"+    , ""+    , "    a) Accompany it with the complete corresponding machine-readable"+    , "    source code, which must be distributed under the terms of Sections"+    , "    1 and 2 above on a medium customarily used for software interchange; or,"+    , ""+    , "    b) Accompany it with a written offer, valid for at least three"+    , "    years, to give any third party, for a charge no more than your"+    , "    cost of physically performing source distribution, a complete"+    , "    machine-readable copy of the corresponding source code, to be"+    , "    distributed under the terms of Sections 1 and 2 above on a medium"+    , "    customarily used for software interchange; or,"+    , ""+    , "    c) Accompany it with the information you received as to the offer"+    , "    to distribute corresponding source code.  (This alternative is"+    , "    allowed only for noncommercial distribution and only if you"+    , "    received the program in object code or executable form with such"+    , "    an offer, in accord with Subsection b above.)"+    , ""+    , "The source code for a work means the preferred form of the work for"+    , "making modifications to it.  For an executable work, complete source"+    , "code means all the source code for all modules it contains, plus any"+    , "associated interface definition files, plus the scripts used to"+    , "control compilation and installation of the executable.  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 components (compiler, kernel, and so on) of the"+    , "operating system on which the executable runs, unless that component"+    , "itself accompanies the executable."+    , ""+    , "If distribution of executable or object code is made by offering"+    , "access to copy from a designated place, then offering equivalent"+    , "access to copy the source code from the same place counts as"+    , "distribution of the source code, even though third parties are not"+    , "compelled to copy the source along with the object code."+    , ""+    , "  4. You may not copy, modify, sublicense, or distribute the Program"+    , "except as expressly provided under this License.  Any attempt"+    , "otherwise to copy, modify, sublicense or distribute the Program is"+    , "void, and will automatically terminate your rights under this License."+    , "However, parties who have received copies, or rights, from you under"+    , "this License will not have their licenses terminated so long as such"+    , "parties remain in full compliance."+    , ""+    , "  5. You are not required to accept this License, since you have not"+    , "signed it.  However, nothing else grants you permission to modify or"+    , "distribute the Program or its derivative works.  These actions are"+    , "prohibited by law if you do not accept this License.  Therefore, by"+    , "modifying or distributing the Program (or any work based on the"+    , "Program), you indicate your acceptance of this License to do so, and"+    , "all its terms and conditions for copying, distributing or modifying"+    , "the Program or works based on it."+    , ""+    , "  6. Each time you redistribute the Program (or any work based on the"+    , "Program), the recipient automatically receives a license from the"+    , "original licensor to copy, distribute or modify the Program 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"+    , "this License."+    , ""+    , "  7. If, as a consequence of a court judgment or allegation of patent"+    , "infringement or for any other reason (not limited to patent issues),"+    , "conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot"+    , "distribute so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you"+    , "may not distribute the Program at all.  For example, if a patent"+    , "license would not permit royalty-free redistribution of the Program by"+    , "all those who receive copies directly or indirectly through you, then"+    , "the only way you could satisfy both it and this License would be to"+    , "refrain entirely from distribution of the Program."+    , ""+    , "If any portion of this section is held invalid or unenforceable under"+    , "any particular circumstance, the balance of the section is intended to"+    , "apply and the section as a whole is intended to apply in other"+    , "circumstances."+    , ""+    , "It is not the purpose of this section to induce you to infringe any"+    , "patents or other property right claims or to contest validity of any"+    , "such claims; this section has the sole purpose of protecting the"+    , "integrity of the free software distribution system, which is"+    , "implemented by public license practices.  Many people have made"+    , "generous contributions to the wide range of software distributed"+    , "through that system in reliance on consistent application of that"+    , "system; it is up to the author/donor to decide if he or she is willing"+    , "to distribute software through any other system and a licensee cannot"+    , "impose that choice."+    , ""+    , "This section is intended to make thoroughly clear what is believed to"+    , "be a consequence of the rest of this License."+    , ""+    , "  8. If the distribution and/or use of the Program is restricted in"+    , "certain countries either by patents or by copyrighted interfaces, the"+    , "original copyright holder who places the Program under this License"+    , "may add an explicit geographical distribution limitation excluding"+    , "those countries, so that distribution is permitted only in or among"+    , "countries not thus excluded.  In such case, this License incorporates"+    , "the limitation as if written in the body of this License."+    , ""+    , "  9. The Free Software Foundation may publish revised and/or new versions"+    , "of the 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."+    , ""+    , "Each version is given a distinguishing version number.  If the Program"+    , "specifies a version number of this License which applies to it and \"any"+    , "later version\", you have the option of following the terms and conditions"+    , "either of that version or of any later version published by the Free"+    , "Software Foundation.  If the Program does not specify a version number of"+    , "this License, you may choose any version ever published by the Free Software"+    , "Foundation."+    , ""+    , "  10. If you wish to incorporate parts of the Program into other free"+    , "programs whose distribution conditions are different, write to the author"+    , "to ask for permission.  For software which is copyrighted by the Free"+    , "Software Foundation, write to the Free Software Foundation; we sometimes"+    , "make exceptions for this.  Our decision will be guided by the two goals"+    , "of preserving the free status of all derivatives of our free software and"+    , "of promoting the sharing and reuse of software generally."+    , ""+    , "                     NO WARRANTY"+    , ""+    , "  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY"+    , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN"+    , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES"+    , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED"+    , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF"+    , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS"+    , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE"+    , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,"+    , "REPAIR OR CORRECTION."+    , ""+    , "  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR"+    , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,"+    , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING"+    , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED"+    , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY"+    , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER"+    , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE"+    , "POSSIBILITY OF SUCH DAMAGES."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "     How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "convey the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software; you can redistribute it and/or modify"+    , "    it under the terms of the GNU General Public License as published by"+    , "    the Free Software Foundation; either version 2 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program 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 General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU General Public License along"+    , "    with this program; 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."+    , ""+    , "If the program is interactive, make it output a short notice like this"+    , "when it starts in an interactive mode:"+    , ""+    , "    Gnomovision version 69, Copyright (C) year name of author"+    , "    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'."+    , "    This is free software, and you are welcome to redistribute it"+    , "    under certain conditions; type `show c' for details."+    , ""+    , "The hypothetical commands `show w' and `show c' should show the appropriate"+    , "parts of the General Public License.  Of course, the commands you use may"+    , "be called something other than `show w' and `show c'; they could even be"+    , "mouse-clicks or menu items--whatever suits your program."+    , ""+    , "You should also get your employer (if you work as a programmer) or your"+    , "school, if any, to sign a \"copyright disclaimer\" for the program, if"+    , "necessary.  Here is a sample; alter the names:"+    , ""+    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the program"+    , "  `Gnomovision' (which makes passes at compilers) written by James Hacker."+    , ""+    , "  <signature of Ty Coon>, 1 April 1989"+    , "  Ty Coon, President of Vice"+    , ""+    , "This General Public License does not permit incorporating your program into"+    , "proprietary programs.  If your program is a subroutine library, you may"+    , "consider it more useful to permit linking proprietary applications with the"+    , "library.  If this is what you want to do, use the GNU Lesser General"+    , "Public License instead of this License."+    ]++gplv3 :: License+gplv3 = unlines+    [ "              GNU GENERAL PUBLIC LICENSE"+    , "                Version 3, 29 June 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                     Preamble"+    , ""+    , "  The GNU General Public License is a free, copyleft license for"+    , "software and other kinds of works."+    , ""+    , "  The licenses for most software and other practical works are designed"+    , "to take away your freedom to share and change the works.  By contrast,"+    , "the GNU General Public License is intended to guarantee your freedom to"+    , "share and change all versions of a program--to make sure it remains free"+    , "software for all its users.  We, the Free Software Foundation, use the"+    , "GNU General Public License for most of our software; it applies also to"+    , "any other work released this way by its authors.  You can apply it to"+    , "your programs, too."+    , ""+    , "  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"+    , "them 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."+    , ""+    , "  To protect your rights, we need to prevent others from denying you"+    , "these rights or asking you to surrender the rights.  Therefore, you have"+    , "certain responsibilities if you distribute copies of the software, or if"+    , "you modify it: responsibilities to respect the freedom of others."+    , ""+    , "  For example, if you distribute copies of such a program, whether"+    , "gratis or for a fee, you must pass on to the recipients the same"+    , "freedoms that you received.  You must make sure that they, too, receive"+    , "or can get the source code.  And you must show them these terms so they"+    , "know their rights."+    , ""+    , "  Developers that use the GNU GPL protect your rights with two steps:"+    , "(1) assert copyright on the software, and (2) offer you this License"+    , "giving you legal permission to copy, distribute and/or modify it."+    , ""+    , "  For the developers' and authors' protection, the GPL clearly explains"+    , "that there is no warranty for this free software.  For both users' and"+    , "authors' sake, the GPL requires that modified versions be marked as"+    , "changed, so that their problems will not be attributed erroneously to"+    , "authors of previous versions."+    , ""+    , "  Some devices are designed to deny users access to install or run"+    , "modified versions of the software inside them, although the manufacturer"+    , "can do so.  This is fundamentally incompatible with the aim of"+    , "protecting users' freedom to change the software.  The systematic"+    , "pattern of such abuse occurs in the area of products for individuals to"+    , "use, which is precisely where it is most unacceptable.  Therefore, we"+    , "have designed this version of the GPL to prohibit the practice for those"+    , "products.  If such problems arise substantially in other domains, we"+    , "stand ready to extend this provision to those domains in future versions"+    , "of the GPL, as needed to protect the freedom of users."+    , ""+    , "  Finally, every program is threatened constantly by software patents."+    , "States should not allow patents to restrict development and use of"+    , "software on general-purpose computers, but in those that do, we wish to"+    , "avoid the special danger that patents applied to a free program could"+    , "make it effectively proprietary.  To prevent this, the GPL assures that"+    , "patents cannot be used to render the program non-free."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "                TERMS AND CONDITIONS"+    , ""+    , "  0. Definitions."+    , ""+    , "  \"This License\" refers to version 3 of the GNU General Public License."+    , ""+    , "  \"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."+    , ""+    , "  To \"modify\" a work means to copy from or adapt all or part of the work"+    , "in a fashion requiring copyright permission, other than the making of an"+    , "exact copy.  The resulting work is called a \"modified version\" of the"+    , "earlier work or a work \"based on\" the earlier work."+    , ""+    , "  A \"covered work\" means either the unmodified Program or a work based"+    , "on the Program."+    , ""+    , "  To \"propagate\" a work means to do anything with it that, without"+    , "permission, would make you directly or secondarily liable for"+    , "infringement under applicable copyright law, except executing it on a"+    , "computer or modifying a private copy.  Propagation includes copying,"+    , "distribution (with or without modification), making available to the"+    , "public, and in some countries other activities as well."+    , ""+    , "  To \"convey\" a work means any kind of propagation that enables other"+    , "parties to make or receive copies.  Mere interaction with a user through"+    , "a computer network, with no transfer of a copy, is not conveying."+    , ""+    , "  An interactive user interface displays \"Appropriate Legal Notices\""+    , "to the extent that it includes a convenient and prominently visible"+    , "feature that (1) displays an appropriate copyright notice, and (2)"+    , "tells the user that there is no warranty for the work (except to the"+    , "extent that warranties are provided), that licensees may convey the"+    , "work under this License, and how to view a copy of this License.  If"+    , "the interface presents a list of user commands or options, such as a"+    , "menu, a prominent item in the list meets this criterion."+    , ""+    , "  1. Source Code."+    , ""+    , "  The \"source code\" for a work means the preferred form of the work"+    , "for making modifications to it.  \"Object code\" means any non-source"+    , "form of a work."+    , ""+    , "  A \"Standard Interface\" means an interface that either is an official"+    , "standard defined by a recognized standards body, or, in the case of"+    , "interfaces specified for a particular programming language, one that"+    , "is widely used among developers working in that language."+    , ""+    , "  The \"System Libraries\" of an executable work include anything, other"+    , "than the work as a whole, that (a) is included in the normal form of"+    , "packaging a Major Component, but which is not part of that Major"+    , "Component, and (b) serves only to enable use of the work with that"+    , "Major Component, or to implement a Standard Interface for which an"+    , "implementation is available to the public in source code form.  A"+    , "\"Major Component\", in this context, means a major essential component"+    , "(kernel, window system, and so on) of the specific operating system"+    , "(if any) on which the executable work runs, or a compiler used to"+    , "produce the work, or an object code interpreter used to run it."+    , ""+    , "  The \"Corresponding Source\" for a work in object code form means all"+    , "the source code needed to generate, install, and (for an executable"+    , "work) run the object code and to modify the work, including scripts to"+    , "control those activities.  However, it does not include the work's"+    , "System Libraries, or general-purpose tools or generally available free"+    , "programs which are used unmodified in performing those activities but"+    , "which are not part of the work.  For example, Corresponding Source"+    , "includes interface definition files associated with source files for"+    , "the work, and the source code for shared libraries and dynamically"+    , "linked subprograms that the work is specifically designed to require,"+    , "such as by intimate data communication or control flow between those"+    , "subprograms and other parts of the work."+    , ""+    , "  The Corresponding Source need not include anything that users"+    , "can regenerate automatically from other parts of the Corresponding"+    , "Source."+    , ""+    , "  The Corresponding Source for a work in source code form is that"+    , "same work."+    , ""+    , "  2. Basic Permissions."+    , ""+    , "  All rights granted under this License are granted for the term of"+    , "copyright on the Program, and are irrevocable provided the stated"+    , "conditions are met.  This License explicitly affirms your unlimited"+    , "permission to run the unmodified Program.  The output from running a"+    , "covered work is covered by this License only if the output, given its"+    , "content, constitutes a covered work.  This License acknowledges your"+    , "rights of fair use or other equivalent, as provided by copyright law."+    , ""+    , "  You may make, run and propagate covered works that you do not"+    , "convey, without conditions so long as your license otherwise remains"+    , "in force.  You may convey covered works to others for the sole purpose"+    , "of having them make modifications exclusively for you, or provide you"+    , "with facilities for running those works, provided that you comply with"+    , "the terms of this License in conveying all material for which you do"+    , "not control copyright.  Those thus making or running the covered works"+    , "for you must do so exclusively on your behalf, under your direction"+    , "and control, on terms that prohibit them from making any copies of"+    , "your copyrighted material outside their relationship with you."+    , ""+    , "  Conveying under any other circumstances is permitted solely under"+    , "the conditions stated below.  Sublicensing is not allowed; section 10"+    , "makes it unnecessary."+    , ""+    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."+    , ""+    , "  No covered work shall be deemed part of an effective technological"+    , "measure under any applicable law fulfilling obligations under article"+    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"+    , "similar laws prohibiting or restricting circumvention of such"+    , "measures."+    , ""+    , "  When you convey a covered work, you waive any legal power to forbid"+    , "circumvention of technological measures to the extent such circumvention"+    , "is effected by exercising rights under this License with respect to"+    , "the covered work, and you disclaim any intention to limit operation or"+    , "modification of the work as a means of enforcing, against the work's"+    , "users, your or third parties' legal rights to forbid circumvention of"+    , "technological measures."+    , ""+    , "  4. Conveying Verbatim Copies."+    , ""+    , "  You may convey verbatim copies of the Program's source code as you"+    , "receive it, in any medium, provided that you conspicuously and"+    , "appropriately publish on each copy an appropriate copyright notice;"+    , "keep intact all notices stating that this License and any"+    , "non-permissive terms added in accord with section 7 apply to the code;"+    , "keep intact all notices of the absence of any warranty; and give all"+    , "recipients a copy of this License along with the Program."+    , ""+    , "  You may charge any price or no price for each copy that you convey,"+    , "and you may offer support or warranty protection for a fee."+    , ""+    , "  5. Conveying Modified Source Versions."+    , ""+    , "  You may convey a work based on the Program, or the modifications to"+    , "produce it from the Program, in the form of source code under the"+    , "terms of section 4, provided that you also meet all of these conditions:"+    , ""+    , "    a) The work must carry prominent notices stating that you modified"+    , "    it, and giving a relevant date."+    , ""+    , "    b) The work must carry prominent notices stating that it is"+    , "    released under this License and any conditions added under section"+    , "    7.  This requirement modifies the requirement in section 4 to"+    , "    \"keep intact all notices\"."+    , ""+    , "    c) You must license the entire work, as a whole, under this"+    , "    License to anyone who comes into possession of a copy.  This"+    , "    License will therefore apply, along with any applicable section 7"+    , "    additional terms, to the whole of the work, and all its parts,"+    , "    regardless of how they are packaged.  This License gives no"+    , "    permission to license the work in any other way, but it does not"+    , "    invalidate such permission if you have separately received it."+    , ""+    , "    d) If the work has interactive user interfaces, each must display"+    , "    Appropriate Legal Notices; however, if the Program has interactive"+    , "    interfaces that do not display Appropriate Legal Notices, your"+    , "    work need not make them do so."+    , ""+    , "  A compilation of a covered work with other separate and independent"+    , "works, which are not by their nature extensions of the covered work,"+    , "and which are not combined with it such as to form a larger program,"+    , "in or on a volume of a storage or distribution medium, is called an"+    , "\"aggregate\" if the compilation and its resulting copyright are not"+    , "used to limit the access or legal rights of the compilation's users"+    , "beyond what the individual works permit.  Inclusion of a covered work"+    , "in an aggregate does not cause this License to apply to the other"+    , "parts of the aggregate."+    , ""+    , "  6. Conveying Non-Source Forms."+    , ""+    , "  You may convey a covered work in object code form under the terms"+    , "of sections 4 and 5, provided that you also convey the"+    , "machine-readable Corresponding Source under the terms of this License,"+    , "in one of these ways:"+    , ""+    , "    a) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by the"+    , "    Corresponding Source fixed on a durable physical medium"+    , "    customarily used for software interchange."+    , ""+    , "    b) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by a"+    , "    written offer, valid for at least three years and valid for as"+    , "    long as you offer spare parts or customer support for that product"+    , "    model, to give anyone who possesses the object code either (1) a"+    , "    copy of the Corresponding Source for all the software in the"+    , "    product that is covered by this License, on a durable physical"+    , "    medium customarily used for software interchange, for a price no"+    , "    more than your reasonable cost of physically performing this"+    , "    conveying of source, or (2) access to copy the"+    , "    Corresponding Source from a network server at no charge."+    , ""+    , "    c) Convey individual copies of the object code with a copy of the"+    , "    written offer to provide the Corresponding Source.  This"+    , "    alternative is allowed only occasionally and noncommercially, and"+    , "    only if you received the object code with such an offer, in accord"+    , "    with subsection 6b."+    , ""+    , "    d) Convey the object code by offering access from a designated"+    , "    place (gratis or for a charge), and offer equivalent access to the"+    , "    Corresponding Source in the same way through the same place at no"+    , "    further charge.  You need not require recipients to copy the"+    , "    Corresponding Source along with the object code.  If the place to"+    , "    copy the object code is a network server, the Corresponding Source"+    , "    may be on a different server (operated by you or a third party)"+    , "    that supports equivalent copying facilities, provided you maintain"+    , "    clear directions next to the object code saying where to find the"+    , "    Corresponding Source.  Regardless of what server hosts the"+    , "    Corresponding Source, you remain obligated to ensure that it is"+    , "    available for as long as needed to satisfy these requirements."+    , ""+    , "    e) Convey the object code using peer-to-peer transmission, provided"+    , "    you inform other peers where the object code and Corresponding"+    , "    Source of the work are being offered to the general public at no"+    , "    charge under subsection 6d."+    , ""+    , "  A separable portion of the object code, whose source code is excluded"+    , "from the Corresponding Source as a System Library, need not be"+    , "included in conveying the object code work."+    , ""+    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"+    , "tangible personal property which is normally used for personal, family,"+    , "or household purposes, or (2) anything designed or sold for incorporation"+    , "into a dwelling.  In determining whether a product is a consumer product,"+    , "doubtful cases shall be resolved in favor of coverage.  For a particular"+    , "product received by a particular user, \"normally used\" refers to a"+    , "typical or common use of that class of product, regardless of the status"+    , "of the particular user or of the way in which the particular user"+    , "actually uses, or expects or is expected to use, the product.  A product"+    , "is a consumer product regardless of whether the product has substantial"+    , "commercial, industrial or non-consumer uses, unless such uses represent"+    , "the only significant mode of use of the product."+    , ""+    , "  \"Installation Information\" for a User Product means any methods,"+    , "procedures, authorization keys, or other information required to install"+    , "and execute modified versions of a covered work in that User Product from"+    , "a modified version of its Corresponding Source.  The information must"+    , "suffice to ensure that the continued functioning of the modified object"+    , "code is in no case prevented or interfered with solely because"+    , "modification has been made."+    , ""+    , "  If you convey an object code work under this section in, or with, or"+    , "specifically for use in, a User Product, and the conveying occurs as"+    , "part of a transaction in which the right of possession and use of the"+    , "User Product is transferred to the recipient in perpetuity or for a"+    , "fixed term (regardless of how the transaction is characterized), the"+    , "Corresponding Source conveyed under this section must be accompanied"+    , "by the Installation Information.  But this requirement does not apply"+    , "if neither you nor any third party retains the ability to install"+    , "modified object code on the User Product (for example, the work has"+    , "been installed in ROM)."+    , ""+    , "  The requirement to provide Installation Information does not include a"+    , "requirement to continue to provide support service, warranty, or updates"+    , "for a work that has been modified or installed by the recipient, or for"+    , "the User Product in which it has been modified or installed.  Access to a"+    , "network may be denied when the modification itself materially and"+    , "adversely affects the operation of the network or violates the rules and"+    , "protocols for communication across the network."+    , ""+    , "  Corresponding Source conveyed, and Installation Information provided,"+    , "in accord with this section must be in a format that is publicly"+    , "documented (and with an implementation available to the public in"+    , "source code form), and must require no special password or key for"+    , "unpacking, reading or copying."+    , ""+    , "  7. Additional Terms."+    , ""+    , "  \"Additional permissions\" are terms that supplement the terms of this"+    , "License by making exceptions from one or more of its conditions."+    , "Additional permissions that are applicable to the entire Program shall"+    , "be treated as though they were included in this License, to the extent"+    , "that they are valid under applicable law.  If additional permissions"+    , "apply only to part of the Program, that part may be used separately"+    , "under those permissions, but the entire Program remains governed by"+    , "this License without regard to the additional permissions."+    , ""+    , "  When you convey a copy of a covered work, you may at your option"+    , "remove any additional permissions from that copy, or from any part of"+    , "it.  (Additional permissions may be written to require their own"+    , "removal in certain cases when you modify the work.)  You may place"+    , "additional permissions on material, added by you to a covered work,"+    , "for which you have or can give appropriate copyright permission."+    , ""+    , "  Notwithstanding any other provision of this License, for material you"+    , "add to a covered work, you may (if authorized by the copyright holders of"+    , "that material) supplement the terms of this License with terms:"+    , ""+    , "    a) Disclaiming warranty or limiting liability differently from the"+    , "    terms of sections 15 and 16 of this License; or"+    , ""+    , "    b) Requiring preservation of specified reasonable legal notices or"+    , "    author attributions in that material or in the Appropriate Legal"+    , "    Notices displayed by works containing it; or"+    , ""+    , "    c) Prohibiting misrepresentation of the origin of that material, or"+    , "    requiring that modified versions of such material be marked in"+    , "    reasonable ways as different from the original version; or"+    , ""+    , "    d) Limiting the use for publicity purposes of names of licensors or"+    , "    authors of the material; or"+    , ""+    , "    e) Declining to grant rights under trademark law for use of some"+    , "    trade names, trademarks, or service marks; or"+    , ""+    , "    f) Requiring indemnification of licensors and authors of that"+    , "    material by anyone who conveys the material (or modified versions of"+    , "    it) with contractual assumptions of liability to the recipient, for"+    , "    any liability that these contractual assumptions directly impose on"+    , "    those licensors and authors."+    , ""+    , "  All other non-permissive additional terms are considered \"further"+    , "restrictions\" within the meaning of section 10.  If the Program as you"+    , "received it, or any part of it, contains a notice stating that it is"+    , "governed by this License along with a term that is a further"+    , "restriction, you may remove that term.  If a license document contains"+    , "a further restriction but permits relicensing or conveying under this"+    , "License, you may add to a covered work material governed by the terms"+    , "of that license document, provided that the further restriction does"+    , "not survive such relicensing or conveying."+    , ""+    , "  If you add terms to a covered work in accord with this section, you"+    , "must place, in the relevant source files, a statement of the"+    , "additional terms that apply to those files, or a notice indicating"+    , "where to find the applicable terms."+    , ""+    , "  Additional terms, permissive or non-permissive, may be stated in the"+    , "form of a separately written license, or stated as exceptions;"+    , "the above requirements apply either way."+    , ""+    , "  8. Termination."+    , ""+    , "  You may not propagate or modify a covered work except as expressly"+    , "provided under this License.  Any attempt otherwise to propagate or"+    , "modify it is void, and will automatically terminate your rights under"+    , "this License (including any patent licenses granted under the third"+    , "paragraph of section 11)."+    , ""+    , "  However, if you cease all violation of this License, then your"+    , "license from a particular copyright holder is reinstated (a)"+    , "provisionally, unless and until the copyright holder explicitly and"+    , "finally terminates your license, and (b) permanently, if the copyright"+    , "holder fails to notify you of the violation by some reasonable means"+    , "prior to 60 days after the cessation."+    , ""+    , "  Moreover, your license from a particular copyright holder is"+    , "reinstated permanently if the copyright holder notifies you of the"+    , "violation by some reasonable means, this is the first time you have"+    , "received notice of violation of this License (for any work) from that"+    , "copyright holder, and you cure the violation prior to 30 days after"+    , "your receipt of the notice."+    , ""+    , "  Termination of your rights under this section does not terminate the"+    , "licenses of parties who have received copies or rights from you under"+    , "this License.  If your rights have been terminated and not permanently"+    , "reinstated, you do not qualify to receive new licenses for the same"+    , "material under section 10."+    , ""+    , "  9. Acceptance Not Required for Having Copies."+    , ""+    , "  You are not required to accept this License in order to receive or"+    , "run a copy of the Program.  Ancillary propagation of a covered work"+    , "occurring solely as a consequence of using peer-to-peer transmission"+    , "to receive a copy likewise does not require acceptance.  However,"+    , "nothing other than this License grants you permission to propagate or"+    , "modify any covered work.  These actions infringe copyright if you do"+    , "not accept this License.  Therefore, by modifying or propagating a"+    , "covered work, you indicate your acceptance of this License to do so."+    , ""+    , "  10. Automatic Licensing of Downstream Recipients."+    , ""+    , "  Each time you convey a covered work, the recipient automatically"+    , "receives a license from the original licensors, to run, modify and"+    , "propagate that work, subject to this License.  You are not responsible"+    , "for enforcing compliance by third parties with this License."+    , ""+    , "  An \"entity transaction\" is a transaction transferring control of an"+    , "organization, or substantially all assets of one, or subdividing an"+    , "organization, or merging organizations.  If propagation of a covered"+    , "work results from an entity transaction, each party to that"+    , "transaction who receives a copy of the work also receives whatever"+    , "licenses to the work the party's predecessor in interest had or could"+    , "give under the previous paragraph, plus a right to possession of the"+    , "Corresponding Source of the work from the predecessor in interest, if"+    , "the predecessor has it or can get it with reasonable efforts."+    , ""+    , "  You may not impose any further restrictions on the exercise of the"+    , "rights granted or affirmed under this License.  For example, you may"+    , "not impose a license fee, royalty, or other charge for exercise of"+    , "rights granted under this License, and you may not initiate litigation"+    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"+    , "any patent claim is infringed by making, using, selling, offering for"+    , "sale, or importing the Program or any portion of it."+    , ""+    , "  11. Patents."+    , ""+    , "  A \"contributor\" is a copyright holder who authorizes use under this"+    , "License of the Program or a work on which the Program is based.  The"+    , "work thus licensed is called the contributor's \"contributor version\"."+    , ""+    , "  A contributor's \"essential patent claims\" are all patent claims"+    , "owned or controlled by the contributor, whether already acquired or"+    , "hereafter acquired, that would be infringed by some manner, permitted"+    , "by this License, of making, using, or selling its contributor version,"+    , "but do not include claims that would be infringed only as a"+    , "consequence of further modification of the contributor version.  For"+    , "purposes of this definition, \"control\" includes the right to grant"+    , "patent sublicenses in a manner consistent with the requirements of"+    , "this License."+    , ""+    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"+    , "patent license under the contributor's essential patent claims, to"+    , "make, use, sell, offer for sale, import and otherwise run, modify and"+    , "propagate the contents of its contributor version."+    , ""+    , "  In the following three paragraphs, a \"patent license\" is any express"+    , "agreement or commitment, however denominated, not to enforce a patent"+    , "(such as an express permission to practice a patent or covenant not to"+    , "sue for patent infringement).  To \"grant\" such a patent license to a"+    , "party means to make such an agreement or commitment not to enforce a"+    , "patent against the party."+    , ""+    , "  If you convey a covered work, knowingly relying on a patent license,"+    , "and the Corresponding Source of the work is not available for anyone"+    , "to copy, free of charge and under the terms of this License, through a"+    , "publicly available network server or other readily accessible means,"+    , "then you must either (1) cause the Corresponding Source to be so"+    , "available, or (2) arrange to deprive yourself of the benefit of the"+    , "patent license for this particular work, or (3) arrange, in a manner"+    , "consistent with the requirements of this License, to extend the patent"+    , "license to downstream recipients.  \"Knowingly relying\" means you have"+    , "actual knowledge that, but for the patent license, your conveying the"+    , "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"+    , "receiving the covered work authorizing them to use, propagate, modify"+    , "or convey a specific copy of the covered work, then the patent license"+    , "you grant is automatically extended to all recipients of the covered"+    , "work and works based on it."+    , ""+    , "  A patent license is \"discriminatory\" if it does not include within"+    , "the scope of its coverage, prohibits the exercise of, or is"+    , "conditioned on the non-exercise of one or more of the rights that are"+    , "specifically granted under this License.  You may not convey a covered"+    , "work if you are a party to an arrangement with a third party that is"+    , "in the business of distributing software, under which you make payment"+    , "to the third party based on the extent of your activity of conveying"+    , "the work, and under which the third party grants, to any of the"+    , "parties who would receive the covered work from you, a discriminatory"+    , "patent license (a) in connection with copies of the covered work"+    , "conveyed by you (or copies made from those copies), or (b) primarily"+    , "for and in connection with specific products or compilations that"+    , "contain the covered work, unless you entered into that arrangement,"+    , "or that patent license was granted, prior to 28 March 2007."+    , ""+    , "  Nothing in this License shall be construed as excluding or limiting"+    , "any implied license or other defenses to infringement that may"+    , "otherwise be available to you under applicable patent law."+    , ""+    , "  12. No Surrender of Others' Freedom."+    , ""+    , "  If conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot convey a"+    , "covered work so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you may"+    , "not convey it at all.  For example, if you agree to terms that obligate you"+    , "to collect a royalty for further conveying from those to whom you convey"+    , "the Program, the only way you could satisfy both those terms and this"+    , "License would be to refrain entirely from conveying the Program."+    , ""+    , "  13. Use with the GNU Affero General Public License."+    , ""+    , "  Notwithstanding any other provision of this License, you have"+    , "permission to link or combine any covered work with a work licensed"+    , "under version 3 of the GNU Affero General Public License into a single"+    , "combined work, and to convey the resulting work.  The terms of this"+    , "License will continue to apply to the part which is the covered work,"+    , "but the special requirements of the GNU Affero General Public License,"+    , "section 13, concerning interaction through a network will apply to the"+    , "combination as such."+    , ""+    , "  14. Revised Versions of this License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions of"+    , "the GNU 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."+    , ""+    , "  Each version is given a distinguishing version number.  If the"+    , "Program specifies that a certain numbered version of the GNU General"+    , "Public License \"or any later version\" applies to it, you have the"+    , "option of following the terms and conditions either of that numbered"+    , "version or of any later version published by the Free Software"+    , "Foundation.  If the Program does not specify a version number of the"+    , "GNU General Public License, you may choose any version ever published"+    , "by the Free Software Foundation."+    , ""+    , "  If the Program specifies that a proxy can decide which future"+    , "versions of the GNU General Public License can be used, that proxy's"+    , "public statement of acceptance of a version permanently authorizes you"+    , "to choose that version for the Program."+    , ""+    , "  Later license versions may give you additional or different"+    , "permissions.  However, no additional obligations are imposed on any"+    , "author or copyright holder as a result of your choosing to follow a"+    , "later version."+    , ""+    , "  15. Disclaimer of Warranty."+    , ""+    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"+    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"+    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"+    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"+    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"+    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"+    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. Limitation of Liability."+    , ""+    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"+    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"+    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"+    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"+    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"+    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"+    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"+    , "SUCH DAMAGES."+    , ""+    , "  17. Interpretation of Sections 15 and 16."+    , ""+    , "  If the disclaimer of warranty and limitation of liability provided"+    , "above cannot be given local legal effect according to their terms,"+    , "reviewing courts shall apply local law that most closely approximates"+    , "an absolute waiver of all civil liability in connection with the"+    , "Program, unless a warranty or assumption of liability accompanies a"+    , "copy of the Program in return for a fee."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "     How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "state the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software: you can redistribute it and/or modify"+    , "    it under the terms of the GNU General Public License as published by"+    , "    the Free Software Foundation, either version 3 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program 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 General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU General Public License"+    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "  If the program does terminal interaction, make it output a short"+    , "notice like this when it starts in an interactive mode:"+    , ""+    , "    <program>  Copyright (C) <year>  <name of author>"+    , "    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'."+    , "    This is free software, and you are welcome to redistribute it"+    , "    under certain conditions; type `show c' for details."+    , ""+    , "The hypothetical commands `show w' and `show c' should show the appropriate"+    , "parts of the General Public License.  Of course, your program's commands"+    , "might be different; for a GUI interface, you would use an \"about box\"."+    , ""+    , "  You should also get your employer (if you work as a programmer) or school,"+    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."+    , "For more information on this, and how to apply and follow the GNU GPL, see"+    , "<http://www.gnu.org/licenses/>."+    , ""+    , "  The GNU General Public License does not permit incorporating your program"+    , "into proprietary programs.  If your program is a subroutine library, you"+    , "may consider it more useful to permit linking proprietary applications with"+    , "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+agplv3 = unlines+    [ "                    GNU AFFERO GENERAL PUBLIC LICENSE"+    , "                       Version 3, 19 November 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                            Preamble"+    , ""+    , "  The GNU Affero General Public License is a free, copyleft license for"+    , "software and other kinds of works, specifically designed to ensure"+    , "cooperation with the community in the case of network server software."+    , ""+    , "  The licenses for most software and other practical works are designed"+    , "to take away your freedom to share and change the works.  By contrast,"+    , "our General Public Licenses are intended to guarantee your freedom to"+    , "share and change all versions of a program--to make sure it remains free"+    , "software for all its users."+    , ""+    , "  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"+    , "them 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."+    , ""+    , "  Developers that use our General Public Licenses protect your rights"+    , "with two steps: (1) assert copyright on the software, and (2) offer"+    , "you this License which gives you legal permission to copy, distribute"+    , "and/or modify the software."+    , ""+    , "  A secondary benefit of defending all users' freedom is that"+    , "improvements made in alternate versions of the program, if they"+    , "receive widespread use, become available for other developers to"+    , "incorporate.  Many developers of free software are heartened and"+    , "encouraged by the resulting cooperation.  However, in the case of"+    , "software used on network servers, this result may fail to come about."+    , "The GNU General Public License permits making a modified version and"+    , "letting the public access it on a server without ever releasing its"+    , "source code to the public."+    , ""+    , "  The GNU Affero General Public License is designed specifically to"+    , "ensure that, in such cases, the modified source code becomes available"+    , "to the community.  It requires the operator of a network server to"+    , "provide the source code of the modified version running there to the"+    , "users of that server.  Therefore, public use of a modified version, on"+    , "a publicly accessible server, gives the public access to the source"+    , "code of the modified version."+    , ""+    , "  An older license, called the Affero General Public License and"+    , "published by Affero, was designed to accomplish similar goals.  This is"+    , "a different license, not a version of the Affero GPL, but Affero has"+    , "released a new version of the Affero GPL which permits relicensing under"+    , "this license."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "                       TERMS AND CONDITIONS"+    , ""+    , "  0. Definitions."+    , ""+    , "  \"This License\" refers to version 3 of the GNU Affero General Public License."+    , ""+    , "  \"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."+    , ""+    , "  To \"modify\" a work means to copy from or adapt all or part of the work"+    , "in a fashion requiring copyright permission, other than the making of an"+    , "exact copy.  The resulting work is called a \"modified version\" of the"+    , "earlier work or a work \"based on\" the earlier work."+    , ""+    , "  A \"covered work\" means either the unmodified Program or a work based"+    , "on the Program."+    , ""+    , "  To \"propagate\" a work means to do anything with it that, without"+    , "permission, would make you directly or secondarily liable for"+    , "infringement under applicable copyright law, except executing it on a"+    , "computer or modifying a private copy.  Propagation includes copying,"+    , "distribution (with or without modification), making available to the"+    , "public, and in some countries other activities as well."+    , ""+    , "  To \"convey\" a work means any kind of propagation that enables other"+    , "parties to make or receive copies.  Mere interaction with a user through"+    , "a computer network, with no transfer of a copy, is not conveying."+    , ""+    , "  An interactive user interface displays \"Appropriate Legal Notices\""+    , "to the extent that it includes a convenient and prominently visible"+    , "feature that (1) displays an appropriate copyright notice, and (2)"+    , "tells the user that there is no warranty for the work (except to the"+    , "extent that warranties are provided), that licensees may convey the"+    , "work under this License, and how to view a copy of this License.  If"+    , "the interface presents a list of user commands or options, such as a"+    , "menu, a prominent item in the list meets this criterion."+    , ""+    , "  1. Source Code."+    , ""+    , "  The \"source code\" for a work means the preferred form of the work"+    , "for making modifications to it.  \"Object code\" means any non-source"+    , "form of a work."+    , ""+    , "  A \"Standard Interface\" means an interface that either is an official"+    , "standard defined by a recognized standards body, or, in the case of"+    , "interfaces specified for a particular programming language, one that"+    , "is widely used among developers working in that language."+    , ""+    , "  The \"System Libraries\" of an executable work include anything, other"+    , "than the work as a whole, that (a) is included in the normal form of"+    , "packaging a Major Component, but which is not part of that Major"+    , "Component, and (b) serves only to enable use of the work with that"+    , "Major Component, or to implement a Standard Interface for which an"+    , "implementation is available to the public in source code form.  A"+    , "\"Major Component\", in this context, means a major essential component"+    , "(kernel, window system, and so on) of the specific operating system"+    , "(if any) on which the executable work runs, or a compiler used to"+    , "produce the work, or an object code interpreter used to run it."+    , ""+    , "  The \"Corresponding Source\" for a work in object code form means all"+    , "the source code needed to generate, install, and (for an executable"+    , "work) run the object code and to modify the work, including scripts to"+    , "control those activities.  However, it does not include the work's"+    , "System Libraries, or general-purpose tools or generally available free"+    , "programs which are used unmodified in performing those activities but"+    , "which are not part of the work.  For example, Corresponding Source"+    , "includes interface definition files associated with source files for"+    , "the work, and the source code for shared libraries and dynamically"+    , "linked subprograms that the work is specifically designed to require,"+    , "such as by intimate data communication or control flow between those"+    , "subprograms and other parts of the work."+    , ""+    , "  The Corresponding Source need not include anything that users"+    , "can regenerate automatically from other parts of the Corresponding"+    , "Source."+    , ""+    , "  The Corresponding Source for a work in source code form is that"+    , "same work."+    , ""+    , "  2. Basic Permissions."+    , ""+    , "  All rights granted under this License are granted for the term of"+    , "copyright on the Program, and are irrevocable provided the stated"+    , "conditions are met.  This License explicitly affirms your unlimited"+    , "permission to run the unmodified Program.  The output from running a"+    , "covered work is covered by this License only if the output, given its"+    , "content, constitutes a covered work.  This License acknowledges your"+    , "rights of fair use or other equivalent, as provided by copyright law."+    , ""+    , "  You may make, run and propagate covered works that you do not"+    , "convey, without conditions so long as your license otherwise remains"+    , "in force.  You may convey covered works to others for the sole purpose"+    , "of having them make modifications exclusively for you, or provide you"+    , "with facilities for running those works, provided that you comply with"+    , "the terms of this License in conveying all material for which you do"+    , "not control copyright.  Those thus making or running the covered works"+    , "for you must do so exclusively on your behalf, under your direction"+    , "and control, on terms that prohibit them from making any copies of"+    , "your copyrighted material outside their relationship with you."+    , ""+    , "  Conveying under any other circumstances is permitted solely under"+    , "the conditions stated below.  Sublicensing is not allowed; section 10"+    , "makes it unnecessary."+    , ""+    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."+    , ""+    , "  No covered work shall be deemed part of an effective technological"+    , "measure under any applicable law fulfilling obligations under article"+    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"+    , "similar laws prohibiting or restricting circumvention of such"+    , "measures."+    , ""+    , "  When you convey a covered work, you waive any legal power to forbid"+    , "circumvention of technological measures to the extent such circumvention"+    , "is effected by exercising rights under this License with respect to"+    , "the covered work, and you disclaim any intention to limit operation or"+    , "modification of the work as a means of enforcing, against the work's"+    , "users, your or third parties' legal rights to forbid circumvention of"+    , "technological measures."+    , ""+    , "  4. Conveying Verbatim Copies."+    , ""+    , "  You may convey verbatim copies of the Program's source code as you"+    , "receive it, in any medium, provided that you conspicuously and"+    , "appropriately publish on each copy an appropriate copyright notice;"+    , "keep intact all notices stating that this License and any"+    , "non-permissive terms added in accord with section 7 apply to the code;"+    , "keep intact all notices of the absence of any warranty; and give all"+    , "recipients a copy of this License along with the Program."+    , ""+    , "  You may charge any price or no price for each copy that you convey,"+    , "and you may offer support or warranty protection for a fee."+    , ""+    , "  5. Conveying Modified Source Versions."+    , ""+    , "  You may convey a work based on the Program, or the modifications to"+    , "produce it from the Program, in the form of source code under the"+    , "terms of section 4, provided that you also meet all of these conditions:"+    , ""+    , "    a) The work must carry prominent notices stating that you modified"+    , "    it, and giving a relevant date."+    , ""+    , "    b) The work must carry prominent notices stating that it is"+    , "    released under this License and any conditions added under section"+    , "    7.  This requirement modifies the requirement in section 4 to"+    , "    \"keep intact all notices\"."+    , ""+    , "    c) You must license the entire work, as a whole, under this"+    , "    License to anyone who comes into possession of a copy.  This"+    , "    License will therefore apply, along with any applicable section 7"+    , "    additional terms, to the whole of the work, and all its parts,"+    , "    regardless of how they are packaged.  This License gives no"+    , "    permission to license the work in any other way, but it does not"+    , "    invalidate such permission if you have separately received it."+    , ""+    , "    d) If the work has interactive user interfaces, each must display"+    , "    Appropriate Legal Notices; however, if the Program has interactive"+    , "    interfaces that do not display Appropriate Legal Notices, your"+    , "    work need not make them do so."+    , ""+    , "  A compilation of a covered work with other separate and independent"+    , "works, which are not by their nature extensions of the covered work,"+    , "and which are not combined with it such as to form a larger program,"+    , "in or on a volume of a storage or distribution medium, is called an"+    , "\"aggregate\" if the compilation and its resulting copyright are not"+    , "used to limit the access or legal rights of the compilation's users"+    , "beyond what the individual works permit.  Inclusion of a covered work"+    , "in an aggregate does not cause this License to apply to the other"+    , "parts of the aggregate."+    , ""+    , "  6. Conveying Non-Source Forms."+    , ""+    , "  You may convey a covered work in object code form under the terms"+    , "of sections 4 and 5, provided that you also convey the"+    , "machine-readable Corresponding Source under the terms of this License,"+    , "in one of these ways:"+    , ""+    , "    a) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by the"+    , "    Corresponding Source fixed on a durable physical medium"+    , "    customarily used for software interchange."+    , ""+    , "    b) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by a"+    , "    written offer, valid for at least three years and valid for as"+    , "    long as you offer spare parts or customer support for that product"+    , "    model, to give anyone who possesses the object code either (1) a"+    , "    copy of the Corresponding Source for all the software in the"+    , "    product that is covered by this License, on a durable physical"+    , "    medium customarily used for software interchange, for a price no"+    , "    more than your reasonable cost of physically performing this"+    , "    conveying of source, or (2) access to copy the"+    , "    Corresponding Source from a network server at no charge."+    , ""+    , "    c) Convey individual copies of the object code with a copy of the"+    , "    written offer to provide the Corresponding Source.  This"+    , "    alternative is allowed only occasionally and noncommercially, and"+    , "    only if you received the object code with such an offer, in accord"+    , "    with subsection 6b."+    , ""+    , "    d) Convey the object code by offering access from a designated"+    , "    place (gratis or for a charge), and offer equivalent access to the"+    , "    Corresponding Source in the same way through the same place at no"+    , "    further charge.  You need not require recipients to copy the"+    , "    Corresponding Source along with the object code.  If the place to"+    , "    copy the object code is a network server, the Corresponding Source"+    , "    may be on a different server (operated by you or a third party)"+    , "    that supports equivalent copying facilities, provided you maintain"+    , "    clear directions next to the object code saying where to find the"+    , "    Corresponding Source.  Regardless of what server hosts the"+    , "    Corresponding Source, you remain obligated to ensure that it is"+    , "    available for as long as needed to satisfy these requirements."+    , ""+    , "    e) Convey the object code using peer-to-peer transmission, provided"+    , "    you inform other peers where the object code and Corresponding"+    , "    Source of the work are being offered to the general public at no"+    , "    charge under subsection 6d."+    , ""+    , "  A separable portion of the object code, whose source code is excluded"+    , "from the Corresponding Source as a System Library, need not be"+    , "included in conveying the object code work."+    , ""+    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"+    , "tangible personal property which is normally used for personal, family,"+    , "or household purposes, or (2) anything designed or sold for incorporation"+    , "into a dwelling.  In determining whether a product is a consumer product,"+    , "doubtful cases shall be resolved in favor of coverage.  For a particular"+    , "product received by a particular user, \"normally used\" refers to a"+    , "typical or common use of that class of product, regardless of the status"+    , "of the particular user or of the way in which the particular user"+    , "actually uses, or expects or is expected to use, the product.  A product"+    , "is a consumer product regardless of whether the product has substantial"+    , "commercial, industrial or non-consumer uses, unless such uses represent"+    , "the only significant mode of use of the product."+    , ""+    , "  \"Installation Information\" for a User Product means any methods,"+    , "procedures, authorization keys, or other information required to install"+    , "and execute modified versions of a covered work in that User Product from"+    , "a modified version of its Corresponding Source.  The information must"+    , "suffice to ensure that the continued functioning of the modified object"+    , "code is in no case prevented or interfered with solely because"+    , "modification has been made."+    , ""+    , "  If you convey an object code work under this section in, or with, or"+    , "specifically for use in, a User Product, and the conveying occurs as"+    , "part of a transaction in which the right of possession and use of the"+    , "User Product is transferred to the recipient in perpetuity or for a"+    , "fixed term (regardless of how the transaction is characterized), the"+    , "Corresponding Source conveyed under this section must be accompanied"+    , "by the Installation Information.  But this requirement does not apply"+    , "if neither you nor any third party retains the ability to install"+    , "modified object code on the User Product (for example, the work has"+    , "been installed in ROM)."+    , ""+    , "  The requirement to provide Installation Information does not include a"+    , "requirement to continue to provide support service, warranty, or updates"+    , "for a work that has been modified or installed by the recipient, or for"+    , "the User Product in which it has been modified or installed.  Access to a"+    , "network may be denied when the modification itself materially and"+    , "adversely affects the operation of the network or violates the rules and"+    , "protocols for communication across the network."+    , ""+    , "  Corresponding Source conveyed, and Installation Information provided,"+    , "in accord with this section must be in a format that is publicly"+    , "documented (and with an implementation available to the public in"+    , "source code form), and must require no special password or key for"+    , "unpacking, reading or copying."+    , ""+    , "  7. Additional Terms."+    , ""+    , "  \"Additional permissions\" are terms that supplement the terms of this"+    , "License by making exceptions from one or more of its conditions."+    , "Additional permissions that are applicable to the entire Program shall"+    , "be treated as though they were included in this License, to the extent"+    , "that they are valid under applicable law.  If additional permissions"+    , "apply only to part of the Program, that part may be used separately"+    , "under those permissions, but the entire Program remains governed by"+    , "this License without regard to the additional permissions."+    , ""+    , "  When you convey a copy of a covered work, you may at your option"+    , "remove any additional permissions from that copy, or from any part of"+    , "it.  (Additional permissions may be written to require their own"+    , "removal in certain cases when you modify the work.)  You may place"+    , "additional permissions on material, added by you to a covered work,"+    , "for which you have or can give appropriate copyright permission."+    , ""+    , "  Notwithstanding any other provision of this License, for material you"+    , "add to a covered work, you may (if authorized by the copyright holders of"+    , "that material) supplement the terms of this License with terms:"+    , ""+    , "    a) Disclaiming warranty or limiting liability differently from the"+    , "    terms of sections 15 and 16 of this License; or"+    , ""+    , "    b) Requiring preservation of specified reasonable legal notices or"+    , "    author attributions in that material or in the Appropriate Legal"+    , "    Notices displayed by works containing it; or"+    , ""+    , "    c) Prohibiting misrepresentation of the origin of that material, or"+    , "    requiring that modified versions of such material be marked in"+    , "    reasonable ways as different from the original version; or"+    , ""+    , "    d) Limiting the use for publicity purposes of names of licensors or"+    , "    authors of the material; or"+    , ""+    , "    e) Declining to grant rights under trademark law for use of some"+    , "    trade names, trademarks, or service marks; or"+    , ""+    , "    f) Requiring indemnification of licensors and authors of that"+    , "    material by anyone who conveys the material (or modified versions of"+    , "    it) with contractual assumptions of liability to the recipient, for"+    , "    any liability that these contractual assumptions directly impose on"+    , "    those licensors and authors."+    , ""+    , "  All other non-permissive additional terms are considered \"further"+    , "restrictions\" within the meaning of section 10.  If the Program as you"+    , "received it, or any part of it, contains a notice stating that it is"+    , "governed by this License along with a term that is a further"+    , "restriction, you may remove that term.  If a license document contains"+    , "a further restriction but permits relicensing or conveying under this"+    , "License, you may add to a covered work material governed by the terms"+    , "of that license document, provided that the further restriction does"+    , "not survive such relicensing or conveying."+    , ""+    , "  If you add terms to a covered work in accord with this section, you"+    , "must place, in the relevant source files, a statement of the"+    , "additional terms that apply to those files, or a notice indicating"+    , "where to find the applicable terms."+    , ""+    , "  Additional terms, permissive or non-permissive, may be stated in the"+    , "form of a separately written license, or stated as exceptions;"+    , "the above requirements apply either way."+    , ""+    , "  8. Termination."+    , ""+    , "  You may not propagate or modify a covered work except as expressly"+    , "provided under this License.  Any attempt otherwise to propagate or"+    , "modify it is void, and will automatically terminate your rights under"+    , "this License (including any patent licenses granted under the third"+    , "paragraph of section 11)."+    , ""+    , "  However, if you cease all violation of this License, then your"+    , "license from a particular copyright holder is reinstated (a)"+    , "provisionally, unless and until the copyright holder explicitly and"+    , "finally terminates your license, and (b) permanently, if the copyright"+    , "holder fails to notify you of the violation by some reasonable means"+    , "prior to 60 days after the cessation."+    , ""+    , "  Moreover, your license from a particular copyright holder is"+    , "reinstated permanently if the copyright holder notifies you of the"+    , "violation by some reasonable means, this is the first time you have"+    , "received notice of violation of this License (for any work) from that"+    , "copyright holder, and you cure the violation prior to 30 days after"+    , "your receipt of the notice."+    , ""+    , "  Termination of your rights under this section does not terminate the"+    , "licenses of parties who have received copies or rights from you under"+    , "this License.  If your rights have been terminated and not permanently"+    , "reinstated, you do not qualify to receive new licenses for the same"+    , "material under section 10."+    , ""+    , "  9. Acceptance Not Required for Having Copies."+    , ""+    , "  You are not required to accept this License in order to receive or"+    , "run a copy of the Program.  Ancillary propagation of a covered work"+    , "occurring solely as a consequence of using peer-to-peer transmission"+    , "to receive a copy likewise does not require acceptance.  However,"+    , "nothing other than this License grants you permission to propagate or"+    , "modify any covered work.  These actions infringe copyright if you do"+    , "not accept this License.  Therefore, by modifying or propagating a"+    , "covered work, you indicate your acceptance of this License to do so."+    , ""+    , "  10. Automatic Licensing of Downstream Recipients."+    , ""+    , "  Each time you convey a covered work, the recipient automatically"+    , "receives a license from the original licensors, to run, modify and"+    , "propagate that work, subject to this License.  You are not responsible"+    , "for enforcing compliance by third parties with this License."+    , ""+    , "  An \"entity transaction\" is a transaction transferring control of an"+    , "organization, or substantially all assets of one, or subdividing an"+    , "organization, or merging organizations.  If propagation of a covered"+    , "work results from an entity transaction, each party to that"+    , "transaction who receives a copy of the work also receives whatever"+    , "licenses to the work the party's predecessor in interest had or could"+    , "give under the previous paragraph, plus a right to possession of the"+    , "Corresponding Source of the work from the predecessor in interest, if"+    , "the predecessor has it or can get it with reasonable efforts."+    , ""+    , "  You may not impose any further restrictions on the exercise of the"+    , "rights granted or affirmed under this License.  For example, you may"+    , "not impose a license fee, royalty, or other charge for exercise of"+    , "rights granted under this License, and you may not initiate litigation"+    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"+    , "any patent claim is infringed by making, using, selling, offering for"+    , "sale, or importing the Program or any portion of it."+    , ""+    , "  11. Patents."+    , ""+    , "  A \"contributor\" is a copyright holder who authorizes use under this"+    , "License of the Program or a work on which the Program is based.  The"+    , "work thus licensed is called the contributor's \"contributor version\"."+    , ""+    , "  A contributor's \"essential patent claims\" are all patent claims"+    , "owned or controlled by the contributor, whether already acquired or"+    , "hereafter acquired, that would be infringed by some manner, permitted"+    , "by this License, of making, using, or selling its contributor version,"+    , "but do not include claims that would be infringed only as a"+    , "consequence of further modification of the contributor version.  For"+    , "purposes of this definition, \"control\" includes the right to grant"+    , "patent sublicenses in a manner consistent with the requirements of"+    , "this License."+    , ""+    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"+    , "patent license under the contributor's essential patent claims, to"+    , "make, use, sell, offer for sale, import and otherwise run, modify and"+    , "propagate the contents of its contributor version."+    , ""+    , "  In the following three paragraphs, a \"patent license\" is any express"+    , "agreement or commitment, however denominated, not to enforce a patent"+    , "(such as an express permission to practice a patent or covenant not to"+    , "sue for patent infringement).  To \"grant\" such a patent license to a"+    , "party means to make such an agreement or commitment not to enforce a"+    , "patent against the party."+    , ""+    , "  If you convey a covered work, knowingly relying on a patent license,"+    , "and the Corresponding Source of the work is not available for anyone"+    , "to copy, free of charge and under the terms of this License, through a"+    , "publicly available network server or other readily accessible means,"+    , "then you must either (1) cause the Corresponding Source to be so"+    , "available, or (2) arrange to deprive yourself of the benefit of the"+    , "patent license for this particular work, or (3) arrange, in a manner"+    , "consistent with the requirements of this License, to extend the patent"+    , "license to downstream recipients.  \"Knowingly relying\" means you have"+    , "actual knowledge that, but for the patent license, your conveying the"+    , "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"+    , "receiving the covered work authorizing them to use, propagate, modify"+    , "or convey a specific copy of the covered work, then the patent license"+    , "you grant is automatically extended to all recipients of the covered"+    , "work and works based on it."+    , ""+    , "  A patent license is \"discriminatory\" if it does not include within"+    , "the scope of its coverage, prohibits the exercise of, or is"+    , "conditioned on the non-exercise of one or more of the rights that are"+    , "specifically granted under this License.  You may not convey a covered"+    , "work if you are a party to an arrangement with a third party that is"+    , "in the business of distributing software, under which you make payment"+    , "to the third party based on the extent of your activity of conveying"+    , "the work, and under which the third party grants, to any of the"+    , "parties who would receive the covered work from you, a discriminatory"+    , "patent license (a) in connection with copies of the covered work"+    , "conveyed by you (or copies made from those copies), or (b) primarily"+    , "for and in connection with specific products or compilations that"+    , "contain the covered work, unless you entered into that arrangement,"+    , "or that patent license was granted, prior to 28 March 2007."+    , ""+    , "  Nothing in this License shall be construed as excluding or limiting"+    , "any implied license or other defenses to infringement that may"+    , "otherwise be available to you under applicable patent law."+    , ""+    , "  12. No Surrender of Others' Freedom."+    , ""+    , "  If conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot convey a"+    , "covered work so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you may"+    , "not convey it at all.  For example, if you agree to terms that obligate you"+    , "to collect a royalty for further conveying from those to whom you convey"+    , "the Program, the only way you could satisfy both those terms and this"+    , "License would be to refrain entirely from conveying the Program."+    , ""+    , "  13. Remote Network Interaction; Use with the GNU General Public License."+    , ""+    , "  Notwithstanding any other provision of this License, if you modify the"+    , "Program, your modified version must prominently offer all users"+    , "interacting with it remotely through a computer network (if your version"+    , "supports such interaction) an opportunity to receive the Corresponding"+    , "Source of your version by providing access to the Corresponding Source"+    , "from a network server at no charge, through some standard or customary"+    , "means of facilitating copying of software.  This Corresponding Source"+    , "shall include the Corresponding Source for any work covered by version 3"+    , "of the GNU General Public License that is incorporated pursuant to the"+    , "following paragraph."+    , ""+    , "  Notwithstanding any other provision of this License, you have"+    , "permission to link or combine any covered work with a work licensed"+    , "under version 3 of the GNU General Public License into a single"+    , "combined work, and to convey the resulting work.  The terms of this"+    , "License will continue to apply to the part which is the covered work,"+    , "but the work with which it is combined will remain governed by version"+    , "3 of the GNU General Public License."+    , ""+    , "  14. Revised Versions of this License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions of"+    , "the GNU Affero 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."+    , ""+    , "  Each version is given a distinguishing version number.  If the"+    , "Program specifies that a certain numbered version of the GNU Affero General"+    , "Public License \"or any later version\" applies to it, you have the"+    , "option of following the terms and conditions either of that numbered"+    , "version or of any later version published by the Free Software"+    , "Foundation.  If the Program does not specify a version number of the"+    , "GNU Affero General Public License, you may choose any version ever published"+    , "by the Free Software Foundation."+    , ""+    , "  If the Program specifies that a proxy can decide which future"+    , "versions of the GNU Affero General Public License can be used, that proxy's"+    , "public statement of acceptance of a version permanently authorizes you"+    , "to choose that version for the Program."+    , ""+    , "  Later license versions may give you additional or different"+    , "permissions.  However, no additional obligations are imposed on any"+    , "author or copyright holder as a result of your choosing to follow a"+    , "later version."+    , ""+    , "  15. Disclaimer of Warranty."+    , ""+    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"+    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"+    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"+    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"+    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"+    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"+    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. Limitation of Liability."+    , ""+    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"+    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"+    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"+    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"+    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"+    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"+    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"+    , "SUCH DAMAGES."+    , ""+    , "  17. Interpretation of Sections 15 and 16."+    , ""+    , "  If the disclaimer of warranty and limitation of liability provided"+    , "above cannot be given local legal effect according to their terms,"+    , "reviewing courts shall apply local law that most closely approximates"+    , "an absolute waiver of all civil liability in connection with the"+    , "Program, unless a warranty or assumption of liability accompanies a"+    , "copy of the Program in return for a fee."+    , ""+    , "                     END OF TERMS AND CONDITIONS"+    , ""+    , "            How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "state the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software: you can redistribute it and/or modify"+    , "    it under the terms of the GNU Affero General Public License as published by"+    , "    the Free Software Foundation, either version 3 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program 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 Affero General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU Affero General Public License"+    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "  If your software can interact with users remotely through a computer"+    , "network, you should also make sure that it provides a way for users to"+    , "get its source.  For example, if your program is a web application, its"+    , "interface could display a \"Source\" link that leads users to an archive"+    , "of the code.  There are many ways you could offer source, and different"+    , "solutions will be better for different programs; see section 13 for the"+    , "specific requirements."+    , ""+    , "  You should also get your employer (if you work as a programmer) or school,"+    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."+    , "For more information on this, and how to apply and follow the GNU AGPL, see"+    , "<http://www.gnu.org/licenses/>."+    ]++lgpl21 :: License+lgpl21 = unlines+    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "                       Version 2.1, February 1999"+    , ""+    , " 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 Lesser GPL.  It also counts"+    , " as the successor of the GNU Library Public License, version 2, hence"+    , " the version number 2.1.]"+    , ""+    , "                            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 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 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"+    , "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 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."+    , ""+    , "  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."+    , ""+    , "  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, 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.  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."+    , ""+    , "  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."+    , ""+    , "  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."+    , ""+    , "  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, whereas the latter must"+    , "be combined with the library in order to run."+    , ""+    , "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+    , ""+    , "  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"+    , "(which use some of those functions and data) to form executables."+    , ""+    , "  The \"Library\", below, refers to any such software library or work"+    , "which has been distributed under these terms.  A \"work based on the"+    , "Library\" means either the Library or any derivative work under"+    , "copyright law: that is to say, a work containing the Library or a"+    , "portion of it, either verbatim or with modifications and/or translated"+    , "straightforwardly into another language.  (Hereinafter, translation is"+    , "included without limitation in the term \"modification\".)"+    , ""+    , "  \"Source code\" for a work means the preferred form of the work for"+    , "making modifications to it.  For a library, complete source code means"+    , "all the source code for all modules it contains, plus any associated"+    , "interface definition files, plus the scripts used to control compilation"+    , "and installation of the library."+    , ""+    , "  Activities other than copying, distribution and modification are not"+    , "covered by this License; they are outside its scope.  The act of"+    , "running a program using the Library is not restricted, and output from"+    , "such a program is covered only if its contents constitute a work based"+    , "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"+    , "appropriate copyright notice and disclaimer of warranty; keep intact"+    , "all the notices that refer to this License and to the absence of any"+    , "warranty; and distribute a copy of this License along with the"+    , "Library."+    , ""+    , "  You may charge a fee for the physical act of transferring a copy,"+    , "and you may at your option offer warranty protection in exchange for a"+    , "fee."+    , ""+    , "  2. You may modify your copy or copies of the Library or any portion"+    , "of it, thus forming a work based on the Library, and copy and"+    , "distribute such modifications or work under the terms of Section 1"+    , "above, provided that you also meet all of these conditions:"+    , ""+    , "    a) The modified work must itself be a software library."+    , ""+    , "    b) You must cause the files modified to carry prominent notices"+    , "    stating that you changed the files and the date of any change."+    , ""+    , "    c) You must cause the whole of the work to be licensed at no"+    , "    charge to all third parties under the terms of this License."+    , ""+    , "    d) If a facility in the modified Library refers to a function or a"+    , "    table of data to be supplied by an application program that uses"+    , "    the facility, other than as an argument passed when the facility"+    , "    is invoked, then you must make a good faith effort to ensure that,"+    , "    in the event an application does not supply such function or"+    , "    table, the facility still operates, and performs whatever part of"+    , "    its purpose remains meaningful."+    , ""+    , "    (For example, a function in a library to compute square roots has"+    , "    a purpose that is entirely well-defined independent of the"+    , "    application.  Therefore, Subsection 2d requires that any"+    , "    application-supplied function or table used by this function must"+    , "    be optional: if the application does not supply it, the square"+    , "    root function must still compute square roots.)"+    , ""+    , "These requirements apply to the modified work as a whole.  If"+    , "identifiable sections of that work are not derived from the Library,"+    , "and can be reasonably considered independent and separate works in"+    , "themselves, then this License, and its terms, do not apply to those"+    , "sections when you distribute them as separate works.  But when you"+    , "distribute the same sections as part of a whole which is a work based"+    , "on the Library, the distribution of the whole must be on the terms of"+    , "this License, whose permissions for other licensees extend to the"+    , "entire whole, and thus to each and every part regardless of who wrote"+    , "it."+    , ""+    , "Thus, it is not the intent of this section to claim rights or contest"+    , "your rights to work written entirely by you; rather, the intent is to"+    , "exercise the right to control the distribution of derivative or"+    , "collective works based on the Library."+    , ""+    , "In addition, mere aggregation of another work not based on the Library"+    , "with the Library (or with a work based on the Library) on a volume of"+    , "a storage or distribution medium does not bring the other work under"+    , "the scope of this License."+    , ""+    , "  3. You may opt to apply the terms of the ordinary GNU General Public"+    , "License instead of this License to a given copy of the Library.  To do"+    , "this, you must alter all the notices that refer to this License, so"+    , "that they refer to the ordinary GNU General Public License, version 2,"+    , "instead of to this License.  (If a newer version than version 2 of the"+    , "ordinary GNU General Public License has appeared, then you can specify"+    , "that version instead if you wish.)  Do not make any other change in"+    , "these notices."+    , ""+    , "  Once this change is made in a given copy, it is irreversible for"+    , "that copy, so the ordinary GNU General Public License applies to all"+    , "subsequent copies and derivative works made from that copy."+    , ""+    , "  This option is useful when you wish to copy part of the code of"+    , "the Library into a program that is not a library."+    , ""+    , "  4. You may copy and distribute the Library (or a portion or"+    , "derivative of it, under Section 2) in object code or executable form"+    , "under the terms of Sections 1 and 2 above provided that you accompany"+    , "it with the complete corresponding machine-readable source code, which"+    , "must be distributed under the terms of Sections 1 and 2 above on a"+    , "medium customarily used for software interchange."+    , ""+    , "  If distribution of object code is made by offering access to copy"+    , "from a designated place, then offering equivalent access to copy the"+    , "source code from the same place satisfies the requirement to"+    , "distribute the source code, even though third parties are not"+    , "compelled to copy the source along with the object code."+    , ""+    , "  5. A program that contains no derivative of any portion of the"+    , "Library, but is designed to work with the Library by being compiled or"+    , "linked with it, is called a \"work that uses the Library\".  Such a"+    , "work, in isolation, is not a derivative work of the Library, and"+    , "therefore falls outside the scope of this License."+    , ""+    , "  However, linking a \"work that uses the Library\" with the Library"+    , "creates an executable that is a derivative of the Library (because it"+    , "contains portions of the Library), rather than a \"work that uses the"+    , "library\".  The executable is therefore covered by this License."+    , "Section 6 states terms for distribution of such executables."+    , ""+    , "  When a \"work that uses the Library\" uses material from a header file"+    , "that is part of the Library, the object code for the work may be a"+    , "derivative work of the Library even though the source code is not."+    , "Whether this is true is especially significant if the work can be"+    , "linked without the Library, or if the work is itself a library.  The"+    , "threshold for this to be true is not precisely defined by law."+    , ""+    , "  If such an object file uses only numerical parameters, data"+    , "structure layouts and accessors, and small macros and small inline"+    , "functions (ten lines or less in length), then the use of the object"+    , "file is unrestricted, regardless of whether it is legally a derivative"+    , "work.  (Executables containing this object code plus portions of the"+    , "Library will still fall under Section 6.)"+    , ""+    , "  Otherwise, if the work is a derivative of the Library, you may"+    , "distribute the object code for the work under the terms of Section 6."+    , "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 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"+    , "modification of the work for the customer's own use and reverse"+    , "engineering for debugging such modifications."+    , ""+    , "  You must give prominent notice with each copy of the work that the"+    , "Library is used in it and that the Library and its use are covered by"+    , "this License.  You must supply a copy of this License.  If the work"+    , "during execution displays copyright notices, you must include the"+    , "copyright notice for the Library among them, as well as a reference"+    , "directing the user to the copy of this License.  Also, you must do one"+    , "of these things:"+    , ""+    , "    a) Accompany the work with the complete corresponding"+    , "    machine-readable source code for the Library including whatever"+    , "    changes were used in the work (which must be distributed under"+    , "    Sections 1 and 2 above); and, if the work is an executable linked"+    , "    with the Library, with the complete machine-readable \"work that"+    , "    uses the Library\", as object code and/or source code, so that the"+    , "    user can modify the Library and then relink to produce a modified"+    , "    executable containing the modified Library.  (It is understood"+    , "    that the user who changes the contents of definitions files in the"+    , "    Library will not necessarily be able to recompile the application"+    , "    to use the modified definitions.)"+    , ""+    , "    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."+    , ""+    , "    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."+    , ""+    , "    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 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."+    , ""+    , "  It may happen that this requirement contradicts the license"+    , "restrictions of other proprietary libraries that do not normally"+    , "accompany the operating system.  Such a contradiction means you cannot"+    , "use both them and the Library together in an executable that you"+    , "distribute."+    , ""+    , "  7. You may place library facilities that are a work based on the"+    , "Library side-by-side in a single library together with other library"+    , "facilities not covered by this License, and distribute such a combined"+    , "library, provided that the separate distribution of the work based on"+    , "the Library and of the other library facilities is otherwise"+    , "permitted, and provided that you do these two things:"+    , ""+    , "    a) Accompany the combined library with a copy of the same work"+    , "    based on the Library, uncombined with any other library"+    , "    facilities.  This must be distributed under the terms of the"+    , "    Sections above."+    , ""+    , "    b) Give prominent notice with the combined library of the fact"+    , "    that part of it is a work based on the Library, and explaining"+    , "    where to find the accompanying uncombined form of the same work."+    , ""+    , "  8. You may not copy, modify, sublicense, link with, or distribute"+    , "the Library except as expressly provided under this License.  Any"+    , "attempt otherwise to copy, modify, sublicense, link with, or"+    , "distribute the Library is void, and will automatically terminate your"+    , "rights under this License.  However, parties who have received copies,"+    , "or rights, from you under this License will not have their licenses"+    , "terminated so long as such parties remain in full compliance."+    , ""+    , "  9. You are not required to accept this License, since you have not"+    , "signed it.  However, nothing else grants you permission to modify or"+    , "distribute the Library or its derivative works.  These actions are"+    , "prohibited by law if you do not accept this License.  Therefore, by"+    , "modifying or distributing the Library (or any work based on the"+    , "Library), you indicate your acceptance of this License to do so, and"+    , "all its terms and conditions for copying, distributing or modifying"+    , "the Library or works based on it."+    , ""+    , "  10. Each time you redistribute the Library (or any work based on the"+    , "Library), the recipient automatically receives a license from the"+    , "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 with"+    , "this License."+    , ""+    , "  11. If, as a consequence of a court judgment or allegation of patent"+    , "infringement or for any other reason (not limited to patent issues),"+    , "conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot"+    , "distribute so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you"+    , "may not distribute the Library at all.  For example, if a patent"+    , "license would not permit royalty-free redistribution of the Library by"+    , "all those who receive copies directly or indirectly through you, then"+    , "the only way you could satisfy both it and this License would be to"+    , "refrain entirely from distribution of the Library."+    , ""+    , "If any portion of this section is held invalid or unenforceable under any"+    , "particular circumstance, the balance of the section is intended to apply,"+    , "and the section as a whole is intended to apply in other circumstances."+    , ""+    , "It is not the purpose of this section to induce you to infringe any"+    , "patents or other property right claims or to contest validity of any"+    , "such claims; this section has the sole purpose of protecting the"+    , "integrity of the free software distribution system which is"+    , "implemented by public license practices.  Many people have made"+    , "generous contributions to the wide range of software distributed"+    , "through that system in reliance on consistent application of that"+    , "system; it is up to the author/donor to decide if he or she is willing"+    , "to distribute software through any other system and a licensee cannot"+    , "impose that choice."+    , ""+    , "This section is intended to make thoroughly clear what is believed to"+    , "be a consequence of the rest of this License."+    , ""+    , "  12. If the distribution and/or use of the Library is restricted in"+    , "certain countries either by patents or by copyrighted interfaces, the"+    , "original copyright holder who places the Library under this License may add"+    , "an explicit geographical distribution limitation excluding those countries,"+    , "so that distribution is permitted only in or among countries not thus"+    , "excluded.  In such case, this License incorporates the limitation as if"+    , "written in the body of this License."+    , ""+    , "  13. The Free Software Foundation may publish revised and/or new"+    , "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."+    , ""+    , "Each version is given a distinguishing version number.  If the Library"+    , "specifies a version number of this License which applies to it and"+    , "\"any later version\", you have the option of following the terms and"+    , "conditions either of that version or of any later version published by"+    , "the Free Software Foundation.  If the Library does not specify a"+    , "license version number, you may choose any version ever published by"+    , "the Free Software Foundation."+    , ""+    , "  14. If you wish to incorporate parts of the Library into other free"+    , "programs whose distribution conditions are incompatible with these,"+    , "write to the author to ask for permission.  For software which is"+    , "copyrighted by the Free Software Foundation, write to the Free"+    , "Software Foundation; we sometimes make exceptions for this.  Our"+    , "decision will be guided by the two goals of preserving the free status"+    , "of all derivatives of our free software and of promoting the sharing"+    , "and reuse of software generally."+    , ""+    , "                            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."+    , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR"+    , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY"+    , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE"+    , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE"+    , "LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME"+    , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN"+    , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY"+    , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU"+    , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR"+    , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE"+    , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING"+    , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A"+    , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF"+    , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"+    , "DAMAGES."+    , ""+    , "                     END OF TERMS AND CONDITIONS"+    , ""+    , "           How to Apply These Terms to Your New Libraries"+    , ""+    , "  If you develop a new library, and you want it to be of the greatest"+    , "possible use to the public, we recommend making it free software that"+    , "everyone can redistribute and change.  You can do so by permitting"+    , "redistribution under these terms (or, alternatively, under the terms of the"+    , "ordinary General Public License)."+    , ""+    , "  To apply these terms, attach the following notices to the library.  It is"+    , "safest to attach them to the start of each source file to most effectively"+    , "convey the exclusion of warranty; and each file should have at least the"+    , "\"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the library's name and a brief idea of what it does.>"+    , "    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 Lesser General Public"+    , "    License as published by the Free Software Foundation; either"+    , "    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"+    , "    Lesser General Public License for more details."+    , ""+    , "    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."+    , ""+    , "You should also get your employer (if you work as a programmer) or your"+    , "school, if any, to sign a \"copyright disclaimer\" for the library, if"+    , "necessary.  Here is a sample; alter the names:"+    , ""+    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the"+    , "  library `Frob' (a library for tweaking knobs) written by James Random Hacker."+    , ""+    , "  <signature of Ty Coon>, 1 April 1990"+    , "  Ty Coon, President of Vice"+    , ""+    , "That's all there is to it!"+    ]++lgpl3 :: License+lgpl3 = unlines+    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "                       Version 3, 29 June 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , ""+    , "  This version of the GNU Lesser General Public License incorporates"+    , "the terms and conditions of version 3 of the GNU General Public"+    , "License, supplemented by the additional permissions listed below."+    , ""+    , "  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"+    , "General Public License."+    , ""+    , "  \"The Library\" refers to a covered work governed by this License,"+    , "other than an Application or a Combined Work as defined below."+    , ""+    , "  An \"Application\" is any work that makes use of an interface provided"+    , "by the Library, but which is not otherwise based on the Library."+    , "Defining a subclass of a class defined by the Library is deemed a mode"+    , "of using an interface provided by the Library."+    , ""+    , "  A \"Combined Work\" is a work produced by combining or linking an"+    , "Application with the Library.  The particular version of the Library"+    , "with which the Combined Work was made is also called the \"Linked"+    , "Version\"."+    , ""+    , "  The \"Minimal Corresponding Source\" for a Combined Work means the"+    , "Corresponding Source for the Combined Work, excluding any source code"+    , "for portions of the Combined Work that, considered in isolation, are"+    , "based on the Application, and not on the Linked Version."+    , ""+    , "  The \"Corresponding Application Code\" for a Combined Work means the"+    , "object code and/or source code for the Application, including any data"+    , "and utility programs needed for reproducing the Combined Work from the"+    , "Application, but excluding the System Libraries of the Combined Work."+    , ""+    , "  1. Exception to Section 3 of the GNU GPL."+    , ""+    , "  You may convey a covered work under sections 3 and 4 of this License"+    , "without being bound by section 3 of the GNU GPL."+    , ""+    , "  2. Conveying Modified Versions."+    , ""+    , "  If you modify a copy of the Library, and, in your modifications, a"+    , "facility refers to a function or data to be supplied by an Application"+    , "that uses the facility (other than as an argument passed when the"+    , "facility is invoked), then you may convey a copy of the modified"+    , "version:"+    , ""+    , "   a) under this License, provided that you make a good faith effort to"+    , "   ensure that, in the event an Application does not supply the"+    , "   function or data, the facility still operates, and performs"+    , "   whatever part of its purpose remains meaningful, or"+    , ""+    , "   b) under the GNU GPL, with none of the additional permissions of"+    , "   this License applicable to that copy."+    , ""+    , "  3. Object Code Incorporating Material from Library Header Files."+    , ""+    , "  The object code form of an Application may incorporate material from"+    , "a header file that is part of the Library.  You may convey such object"+    , "code under terms of your choice, provided that, if the incorporated"+    , "material is not limited to numerical parameters, data structure"+    , "layouts and accessors, or small macros, inline functions and templates"+    , "(ten or fewer lines in length), you do both of the following:"+    , ""+    , "   a) Give prominent notice with each copy of the object code that the"+    , "   Library is used in it and that the Library and its use are"+    , "   covered by this License."+    , ""+    , "   b) Accompany the object code with a copy of the GNU GPL and this license"+    , "   document."+    , ""+    , "  4. Combined Works."+    , ""+    , "  You may convey a Combined Work under terms of your choice that,"+    , "taken together, effectively do not restrict modification of the"+    , "portions of the Library contained in the Combined Work and reverse"+    , "engineering for debugging such modifications, if you also do each of"+    , "the following:"+    , ""+    , "   a) Give prominent notice with each copy of the Combined Work that"+    , "   the Library is used in it and that the Library and its use are"+    , "   covered by this License."+    , ""+    , "   b) Accompany the Combined Work with a copy of the GNU GPL and this license"+    , "   document."+    , ""+    , "   c) For a Combined Work that displays copyright notices during"+    , "   execution, include the copyright notice for the Library among"+    , "   these notices, as well as a reference directing the user to the"+    , "   copies of the GNU GPL and this license document."+    , ""+    , "   d) Do one of the following:"+    , ""+    , "       0) Convey the Minimal Corresponding Source under the terms of this"+    , "       License, and the Corresponding Application Code in a form"+    , "       suitable for, and under terms that permit, the user to"+    , "       recombine or relink the Application with a modified version of"+    , "       the Linked Version to produce a modified Combined Work, in the"+    , "       manner specified by section 6 of the GNU GPL for conveying"+    , "       Corresponding Source."+    , ""+    , "       1) Use a suitable shared library mechanism for linking with the"+    , "       Library.  A suitable mechanism is one that (a) uses at run time"+    , "       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."+    , ""+    , "   e) Provide Installation Information, but only if you would otherwise"+    , "   be required to provide such information under section 6 of the"+    , "   GNU GPL, and only to the extent that such information is"+    , "   necessary to install and execute a modified version of the"+    , "   Combined Work produced by recombining or relinking the"+    , "   Application with a modified version of the Linked Version. (If"+    , "   you use option 4d0, the Installation Information must accompany"+    , "   the Minimal Corresponding Source and Corresponding Application"+    , "   Code. If you use option 4d1, you must provide the Installation"+    , "   Information in the manner specified by section 6 of the GNU GPL"+    , "   for conveying Corresponding Source.)"+    , ""+    , "  5. Combined Libraries."+    , ""+    , "  You may place library facilities that are a work based on the"+    , "Library side by side in a single library together with other library"+    , "facilities that are not Applications and are not covered by this"+    , "License, and convey such a combined library under terms of your"+    , "choice, if you do both of the following:"+    , ""+    , "   a) Accompany the combined library with a copy of the same work based"+    , "   on the Library, uncombined with any other library facilities,"+    , "   conveyed under the terms of this License."+    , ""+    , "   b) Give prominent notice with the combined library that part of it"+    , "   is a work based on the Library, and explaining where to find the"+    , "   accompanying uncombined form of the same work."+    , ""+    , "  6. Revised Versions of the GNU Lesser General Public License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions"+    , "of the GNU 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."+    , ""+    , "  Each version is given a distinguishing version number. If the"+    , "Library as you received it specifies that a certain numbered version"+    , "of the GNU Lesser General Public License \"or any later version\""+    , "applies to it, you have the option of following the terms and"+    , "conditions either of that published version or of any later version"+    , "published by the Free Software Foundation. If the Library as you"+    , "received it does not specify a version number of the GNU Lesser"+    , "General Public License, you may choose any version of the GNU Lesser"+    , "General Public License ever published by the Free Software Foundation."+    , ""+    , "  If the Library as you received it specifies that a proxy can decide"+    , "whether future versions of the GNU Lesser General Public License shall"+    , "apply, that proxy's public statement of acceptance of any version is"+    , "permanent authorization for you to choose that version for the"+    , "Library."+    ]++apache20 :: License+apache20 = unlines+    [ ""+    , "                                 Apache License"+    , "                           Version 2.0, January 2004"+    , "                        http://www.apache.org/licenses/"+    , ""+    , "   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION"+    , ""+    , "   1. Definitions."+    , ""+    , "      \"License\" shall mean the terms and conditions for use, reproduction,"+    , "      and distribution as defined by Sections 1 through 9 of this document."+    , ""+    , "      \"Licensor\" shall mean the copyright owner or entity authorized by"+    , "      the copyright owner that is granting the License."+    , ""+    , "      \"Legal Entity\" shall mean the union of the acting entity and all"+    , "      other entities that control, are controlled by, or are under common"+    , "      control with that entity. For the purposes of this definition,"+    , "      \"control\" means (i) the power, direct or indirect, to cause the"+    , "      direction or management of such entity, whether by contract or"+    , "      otherwise, or (ii) ownership of fifty percent (50%) or more of the"+    , "      outstanding shares, or (iii) beneficial ownership of such entity."+    , ""+    , "      \"You\" (or \"Your\") shall mean an individual or Legal Entity"+    , "      exercising permissions granted by this License."+    , ""+    , "      \"Source\" form shall mean the preferred form for making modifications,"+    , "      including but not limited to software source code, documentation"+    , "      source, and configuration files."+    , ""+    , "      \"Object\" form shall mean any form resulting from mechanical"+    , "      transformation or translation of a Source form, including but"+    , "      not limited to compiled object code, generated documentation,"+    , "      and conversions to other media types."+    , ""+    , "      \"Work\" shall mean the work of authorship, whether in Source or"+    , "      Object form, made available under the License, as indicated by a"+    , "      copyright notice that is included in or attached to the work"+    , "      (an example is provided in the Appendix below)."+    , ""+    , "      \"Derivative Works\" shall mean any work, whether in Source or Object"+    , "      form, that is based on (or derived from) the Work and for which the"+    , "      editorial revisions, annotations, elaborations, or other modifications"+    , "      represent, as a whole, an original work of authorship. For the purposes"+    , "      of this License, Derivative Works shall not include works that remain"+    , "      separable from, or merely link (or bind by name) to the interfaces of,"+    , "      the Work and Derivative Works thereof."+    , ""+    , "      \"Contribution\" shall mean any work of authorship, including"+    , "      the original version of the Work and any modifications or additions"+    , "      to that Work or Derivative Works thereof, that is intentionally"+    , "      submitted to Licensor for inclusion in the Work by the copyright owner"+    , "      or by an individual or Legal Entity authorized to submit on behalf of"+    , "      the copyright owner. For the purposes of this definition, \"submitted\""+    , "      means any form of electronic, verbal, or written communication sent"+    , "      to the Licensor or its representatives, including but not limited to"+    , "      communication on electronic mailing lists, source code control systems,"+    , "      and issue tracking systems that are managed by, or on behalf of, the"+    , "      Licensor for the purpose of discussing and improving the Work, but"+    , "      excluding communication that is conspicuously marked or otherwise"+    , "      designated in writing by the copyright owner as \"Not a Contribution.\""+    , ""+    , "      \"Contributor\" shall mean Licensor and any individual or Legal Entity"+    , "      on behalf of whom a Contribution has been received by Licensor and"+    , "      subsequently incorporated within the Work."+    , ""+    , "   2. Grant of Copyright License. Subject to the terms and conditions of"+    , "      this License, each Contributor hereby grants to You a perpetual,"+    , "      worldwide, non-exclusive, no-charge, royalty-free, irrevocable"+    , "      copyright license to reproduce, prepare Derivative Works of,"+    , "      publicly display, publicly perform, sublicense, and distribute the"+    , "      Work and such Derivative Works in Source or Object form."+    , ""+    , "   3. Grant of Patent License. Subject to the terms and conditions of"+    , "      this License, each Contributor hereby grants to You a perpetual,"+    , "      worldwide, non-exclusive, no-charge, royalty-free, irrevocable"+    , "      (except as stated in this section) patent license to make, have made,"+    , "      use, offer to sell, sell, import, and otherwise transfer the Work,"+    , "      where such license applies only to those patent claims licensable"+    , "      by such Contributor that are necessarily infringed by their"+    , "      Contribution(s) alone or by combination of their Contribution(s)"+    , "      with the Work to which such Contribution(s) was submitted. If You"+    , "      institute patent litigation against any entity (including a"+    , "      cross-claim or counterclaim in a lawsuit) alleging that the Work"+    , "      or a Contribution incorporated within the Work constitutes direct"+    , "      or contributory patent infringement, then any patent licenses"+    , "      granted to You under this License for that Work shall terminate"+    , "      as of the date such litigation is filed."+    , ""+    , "   4. Redistribution. You may reproduce and distribute copies of the"+    , "      Work or Derivative Works thereof in any medium, with or without"+    , "      modifications, and in Source or Object form, provided that You"+    , "      meet the following conditions:"+    , ""+    , "      (a) You must give any other recipients of the Work or"+    , "          Derivative Works a copy of this License; and"+    , ""+    , "      (b) You must cause any modified files to carry prominent notices"+    , "          stating that You changed the files; and"+    , ""+    , "      (c) You must retain, in the Source form of any Derivative Works"+    , "          that You distribute, all copyright, patent, trademark, and"+    , "          attribution notices from the Source form of the Work,"+    , "          excluding those notices that do not pertain to any part of"+    , "          the Derivative Works; and"+    , ""+    , "      (d) If the Work includes a \"NOTICE\" text file as part of its"+    , "          distribution, then any Derivative Works that You distribute must"+    , "          include a readable copy of the attribution notices contained"+    , "          within such NOTICE file, excluding those notices that do not"+    , "          pertain to any part of the Derivative Works, in at least one"+    , "          of the following places: within a NOTICE text file distributed"+    , "          as part of the Derivative Works; within the Source form or"+    , "          documentation, if provided along with the Derivative Works; or,"+    , "          within a display generated by the Derivative Works, if and"+    , "          wherever such third-party notices normally appear. The contents"+    , "          of the NOTICE file are for informational purposes only and"+    , "          do not modify the License. You may add Your own attribution"+    , "          notices within Derivative Works that You distribute, alongside"+    , "          or as an addendum to the NOTICE text from the Work, provided"+    , "          that such additional attribution notices cannot be construed"+    , "          as modifying the License."+    , ""+    , "      You may add Your own copyright statement to Your modifications and"+    , "      may provide additional or different license terms and conditions"+    , "      for use, reproduction, or distribution of Your modifications, or"+    , "      for any such Derivative Works as a whole, provided Your use,"+    , "      reproduction, and distribution of the Work otherwise complies with"+    , "      the conditions stated in this License."+    , ""+    , "   5. Submission of Contributions. Unless You explicitly state otherwise,"+    , "      any Contribution intentionally submitted for inclusion in the Work"+    , "      by You to the Licensor shall be under the terms and conditions of"+    , "      this License, without any additional terms or conditions."+    , "      Notwithstanding the above, nothing herein shall supersede or modify"+    , "      the terms of any separate license agreement you may have executed"+    , "      with Licensor regarding such Contributions."+    , ""+    , "   6. Trademarks. This License does not grant permission to use the trade"+    , "      names, trademarks, service marks, or product names of the Licensor,"+    , "      except as required for reasonable and customary use in describing the"+    , "      origin of the Work and reproducing the content of the NOTICE file."+    , ""+    , "   7. Disclaimer of Warranty. Unless required by applicable law or"+    , "      agreed to in writing, Licensor provides the Work (and each"+    , "      Contributor provides its Contributions) on an \"AS IS\" BASIS,"+    , "      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or"+    , "      implied, including, without limitation, any warranties or conditions"+    , "      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A"+    , "      PARTICULAR PURPOSE. You are solely responsible for determining the"+    , "      appropriateness of using or redistributing the Work and assume any"+    , "      risks associated with Your exercise of permissions under this License."+    , ""+    , "   8. Limitation of Liability. In no event and under no legal theory,"+    , "      whether in tort (including negligence), contract, or otherwise,"+    , "      unless required by applicable law (such as deliberate and grossly"+    , "      negligent acts) or agreed to in writing, shall any Contributor be"+    , "      liable to You for damages, including any direct, indirect, special,"+    , "      incidental, or consequential damages of any character arising as a"+    , "      result of this License or out of the use or inability to use the"+    , "      Work (including but not limited to damages for loss of goodwill,"+    , "      work stoppage, computer failure or malfunction, or any and all"+    , "      other commercial damages or losses), even if such Contributor"+    , "      has been advised of the possibility of such damages."+    , ""+    , "   9. Accepting Warranty or Additional Liability. While redistributing"+    , "      the Work or Derivative Works thereof, You may choose to offer,"+    , "      and charge a fee for, acceptance of support, warranty, indemnity,"+    , "      or other liability obligations and/or rights consistent with this"+    , "      License. However, in accepting such obligations, You may act only"+    , "      on Your own behalf and on Your sole responsibility, not on behalf"+    , "      of any other Contributor, and only if You agree to indemnify,"+    , "      defend, and hold each Contributor harmless for any liability"+    , "      incurred by, or claims asserted against, such Contributor by reason"+    , "      of your accepting any such warranty or additional liability."+    , ""+    , "   END OF TERMS AND CONDITIONS"+    , ""+    , "   APPENDIX: How to apply the Apache License to your work."+    , ""+    , "      To apply the Apache License to your work, attach the following"+    , "      boilerplate notice, with the fields enclosed by brackets \"[]\""+    , "      replaced with your own identifying information. (Don't include"+    , "      the brackets!)  The text should be enclosed in the appropriate"+    , "      comment syntax for the file format. We also recommend that a"+    , "      file or class name and description of purpose be included on the"+    , "      same \"printed page\" as the copyright notice for easier"+    , "      identification within third-party archives."+    , ""+    , "   Copyright [yyyy] [name of copyright owner]"+    , ""+    , "   Licensed under the Apache License, Version 2.0 (the \"License\");"+    , "   you may not use this file except in compliance with the License."+    , "   You may obtain a copy of the License at"+    , ""+    , "       http://www.apache.org/licenses/LICENSE-2.0"+    , ""+    , "   Unless required by applicable law or agreed to in writing, software"+    , "   distributed under the License is distributed on an \"AS IS\" BASIS,"+    , "   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."+    ]++isc :: String -> String -> License+isc authors year = unlines+    [ "Copyright (c) " ++ year ++ " " ++ authors+    , ""+    , "Permission to use, copy, modify, and/or distribute this software for any purpose"+    , "with or without fee is hereby granted, provided that the above copyright notice"+    , "and this permission notice appear in all copies."+    , ""+    , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH"+    , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND"+    , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,"+    , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS"+    , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER"+    , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF"+    , "THIS SOFTWARE."+    ]
+ src/Distribution/Client/Init/Prompt.hs view
@@ -0,0 +1,145 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Prompt+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- User prompt utility functions for use by the 'cabal init' command.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Prompt (++    -- * Commands+    prompt+  , promptYesNo+  , promptStr+  , promptList+  , promptListOptional+  , maybePrompt+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (empty)++import Distribution.Client.Init.Types+  ( InitFlags(..) )+import Distribution.Simple.Setup+  ( Flag(..) )+++-- | Run a prompt or not based on the interactive flag of the+--   InitFlags structure.+maybePrompt :: InitFlags -> IO t -> IO (Maybe t)+maybePrompt flags p =+  case interactive flags of+    Flag True -> Just `fmap` p+    _         -> return Nothing++-- | Create a prompt with optional default value that returns a+--   String.+promptStr :: String -> Maybe String -> IO String+promptStr = promptDefault' Just id++-- | Create a yes/no prompt with optional default value.+promptYesNo :: String      -- ^ prompt message+            -> Maybe Bool  -- ^ optional default value+            -> IO Bool+promptYesNo =+    promptDefault' recogniseYesNo showYesNo+  where+    recogniseYesNo s | s == "y" || s == "Y" = Just True+                     | s == "n" || s == "N" = Just False+                     | otherwise            = Nothing+    showYesNo True  = "y"+    showYesNo False = "n"++-- | Create a prompt with optional default value that returns a value+--   of some Text instance.+prompt :: (Parsec t, Pretty t) => String -> Maybe t -> IO t+prompt = promptDefault' simpleParsec prettyShow++-- | Create a prompt with an optional default value.+promptDefault' :: (String -> Maybe t)       -- ^ parser+               -> (t -> String)             -- ^ pretty-printer+               -> String                    -- ^ prompt message+               -> Maybe t                   -- ^ optional default value+               -> IO t+promptDefault' parser ppr pr def = do+  putStr $ mkDefPrompt pr (ppr `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d)  -> return d+    _  -> case parser inp of+            Just t  -> return t+            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"+                          promptDefault' parser ppr pr def++-- | Create a prompt from a prompt string and a String representation+--   of an optional default value.+mkDefPrompt :: String -> Maybe String -> String+mkDefPrompt pr def = pr ++ "?" ++ defStr def+  where defStr Nothing  = " "+        defStr (Just s) = " [default: " ++ s ++ "] "++-- | Create a prompt from a list of items, where no selected items is+--   valid and will be represented as a return value of 'Nothing'.+promptListOptional :: (Pretty t, Eq t)+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> IO (Maybe (Either String t))+promptListOptional pr choices = promptListOptional' pr choices prettyShow++promptListOptional' :: Eq t+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> (t -> String)     -- ^ show an item+                   -> IO (Maybe (Either String t))+promptListOptional' pr choices displayItem =+    fmap rearrange+  $ promptList pr (Nothing : map Just choices) (Just Nothing)+               (maybe "(none)" displayItem) True+  where+    rearrange = either (Just . Left) (fmap Right)++-- | Create a prompt from a list of items.+promptList :: Eq t+           => String            -- ^ prompt+           -> [t]               -- ^ choices+           -> Maybe t           -- ^ optional default value+           -> (t -> String)     -- ^ show an item+           -> Bool              -- ^ whether to allow an 'other' option+           -> IO (Either String t)+promptList pr choices def displayItem other = do+  putStrLn $ pr ++ ":"+  let options1 = map (\c -> (Just c == def, displayItem c)) choices+      options2 = zip ([1..]::[Int])+                     (options1 ++ [(False, "Other (specify)") | other])+  traverse_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2+  promptList' displayItem (length options2) choices def other+ where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest+                      | otherwise = " " ++ star i ++ rest+                  where rest = show n ++ ") "+                        star True = "*"+                        star False = " "++promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)+promptList' displayItem numChoices choices def other = do+  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d) -> return $ Right d+    _  -> case readMaybe inp of+            Nothing -> invalidChoice inp+            Just n  -> getChoice n+ where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."+                              promptList' displayItem numChoices choices def other+       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)+                   | n < numChoices ||+                     (n == numChoices && not other)+                                  = return . Right $ choices !! (n-1)+                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing
+ src/Distribution/Client/Init/Types.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveGeneric #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Types+-- Copyright   :  (c) Brent Yorgey, Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Some types used by the 'cabal init' command.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Types where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Simple.Setup (Flag(..), toFlag )++import Distribution.Types.Dependency as P+import Distribution.Version+import Distribution.Verbosity+import qualified Distribution.Package as P+import Distribution.SPDX.License (License)+import Distribution.ModuleName+import Distribution.CabalSpecVersion+import Language.Haskell.Extension ( Language(..), Extension )++import qualified Text.PrettyPrint as Disp+import qualified Distribution.Compat.CharParsing as P+import qualified Data.Map as Map++-- | InitFlags is really just a simple type to represent certain+--   portions of a .cabal file.  Rather than have a flag for EVERY+--   possible field, we just have one for each field that the user is+--   likely to want and/or that we are likely to be able to+--   intelligently guess.+data InitFlags =+    InitFlags { interactive    :: Flag Bool+              , quiet          :: Flag Bool+              , packageDir     :: Flag FilePath+              , noComments     :: Flag Bool+              , minimal        :: Flag Bool+              , simpleProject  :: Flag Bool++              , packageName  :: Flag P.PackageName+              , version      :: Flag Version+              , cabalVersion :: Flag CabalSpecVersion+              , license      :: Flag License+              , author       :: Flag String+              , email        :: Flag String+              , homepage     :: Flag String++              , synopsis     :: Flag String+              , category     :: Flag (Either String Category)+              , extraSrc     :: Maybe [String]++              , packageType  :: Flag PackageType+              , mainIs       :: Flag FilePath+              , language     :: Flag Language++              , exposedModules :: Maybe [ModuleName]+              , otherModules   :: Maybe [ModuleName]+              , otherExts      :: Maybe [Extension]++              , dependencies    :: Maybe [P.Dependency]+              , applicationDirs :: Maybe [String]+              , sourceDirs      :: Maybe [String]+              , buildTools      :: Maybe [String]++              , initializeTestSuite :: Flag Bool+              , testDirs            :: Maybe [String]++              , initHcPath    :: Flag FilePath++              , initVerbosity :: Flag Verbosity+              , overwrite     :: Flag Bool+              }+  deriving (Eq, Show, Generic)++  -- the Monoid instance for Flag has later values override earlier+  -- ones, which is why we want Maybe [foo] for collecting foo values,+  -- not Flag [foo].++data BuildType = LibBuild | ExecBuild+  deriving Eq++-- The type of package to initialize.+data PackageType = Library | Executable | LibraryAndExecutable+  deriving (Show, Read, Eq)++displayPackageType :: PackageType -> String+displayPackageType LibraryAndExecutable = "Library and Executable"+displayPackageType pkgtype              = show pkgtype++instance Monoid InitFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup InitFlags where+  (<>) = gmappend++defaultInitFlags :: InitFlags+defaultInitFlags  = mempty+    { initVerbosity = toFlag normal+    }++-- | Some common package categories (non-exhaustive list).+data Category+    = Codec+    | Concurrency+    | Control+    | Data+    | Database+    | Development+    | Distribution+    | Game+    | Graphics+    | Language+    | Math+    | Network+    | Sound+    | System+    | Testing+    | Text+    | Web+    deriving (Read, Show, Eq, Ord, Bounded, Enum)++instance Pretty Category where+  pretty = Disp.text . show++instance Parsec Category where+  parsec = do+    name <- P.munch1 isAlpha+    case Map.lookup name names of+      Just cat -> pure cat+      _        -> P.unexpected $ "Category: " ++ name+    where+      names = Map.fromList [ (show cat, cat) | cat <- [ minBound .. maxBound ] ]
+ src/Distribution/Client/Init/Utils.hs view
@@ -0,0 +1,38 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Utils+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Shared utilities used by multiple cabal init modules.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init.Utils (+    eligibleForTestSuite+  , message+  ) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++import Distribution.Simple.Setup+  ( Flag(..) )+import Distribution.Client.Init.Types+  ( InitFlags(..), PackageType(..) )++-- | Returns true if this package is eligible for test suite initialization.+eligibleForTestSuite :: InitFlags -> Bool+eligibleForTestSuite flags =+  Flag True == initializeTestSuite flags+  && Flag Executable /= packageType flags++-- | Possibly generate a message to stdout, taking into account the+--   --quiet flag.+message :: InitFlags -> String -> IO ()+message (InitFlags{quiet = Flag True}) _ = return ()+message _ s = putStrLn s
+ src/Distribution/Client/Install.hs view
@@ -0,0 +1,1584 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Install+-- Copyright   :  (c) 2005 David Himmelstrup+--                    2007 Bjorn Bringert+--                    2007-2010 Duncan Coutts+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Distribution.Client.Install (+    -- * High-level interface+    install,++    -- * Lower-level interface that allows to manipulate the install plan+    makeInstallContext,+    makeInstallPlan,+    processInstallPlan,+    InstallArgs,+    InstallContext,++    -- * Prune certain packages from the install plan+    pruneInstallPlan+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic(safeLast)++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import Control.Exception as Exception+         ( bracket, catches, Handler(Handler), handleJust )+import System.Directory+         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,+           createDirectoryIfMissing, removeFile, renameDirectory,+           getDirectoryContents )+import System.FilePath+         ( (</>), (<.>), equalFilePath, takeDirectory )+import System.IO+         ( openFile, IOMode(AppendMode), hClose )+import System.IO.Error+         ( isDoesNotExistError, ioeGetFileName )++import Distribution.Client.Targets+import Distribution.Client.Configure+         ( chooseCabalVersion, configureSetupScript, checkConfigExFlags )+import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types+         ( Solver(..) )+import Distribution.Client.FetchUtils+import Distribution.Client.HttpUtils+         ( HttpTransport (..) )+import Distribution.Solver.Types.PackageFixedDeps+import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackagesAtIndexState, getInstalledPackages )+import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)+import Distribution.Client.Setup+         ( GlobalFlags(..), RepoContext(..)+         , ConfigFlags(..), configureCommand, filterConfigureFlags+         , ConfigExFlags(..), InstallFlags(..)+         , filterTestFlags )+import Distribution.Client.Config+         ( getCabalDir, defaultUserInstall )+import Distribution.Client.Tar (extractTarGzFile)+import Distribution.Client.Types as Source+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.BuildReports.Anonymous (showBuildReport)+import qualified Distribution.Client.BuildReports.Anonymous as BuildReports+import qualified Distribution.Client.BuildReports.Storage as BuildReports+         ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )+import qualified Distribution.Client.InstallSymlink as InstallSymlink+         ( symlinkBinaries )+import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import qualified Distribution.Client.World as World+import qualified Distribution.InstalledPackageInfo as Installed+import Distribution.Client.JobControl++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex+import           Distribution.Solver.Types.PkgConfigDb+                   ( PkgConfigDb, readPkgConfigDb )+import           Distribution.Solver.Types.SourcePackage as SourcePackage++import Distribution.Utils.NubList+import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId), compilerFlavor+         , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program (ProgramDb)+import qualified Distribution.Simple.InstallDirs as InstallDirs+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import Distribution.Simple.Setup+         ( haddockCommand, HaddockFlags(..)+         , buildCommand, BuildFlags(..), emptyBuildFlags+         , TestFlags, BenchmarkFlags+         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )+import qualified Distribution.Simple.Setup as Cabal+         ( Flag(..)+         , copyCommand, CopyFlags(..), emptyCopyFlags+         , registerCommand, RegisterFlags(..), emptyRegisterFlags+         , testCommand, TestFlags(..) )+import Distribution.Simple.Utils+         ( createDirectoryIfMissingVerbose, writeFileAtomic )+import Distribution.Simple.InstallDirs as InstallDirs+         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate+         , initialPathTemplateEnv, installDirsTemplateEnv )+import Distribution.Simple.Configure (interpretPackageDbFlags)+import Distribution.Simple.Register (registerPackage, defaultRegisterOptions)+import Distribution.Package+         ( PackageIdentifier(..), PackageId, packageName, packageVersion+         , Package(..), HasMungedPackageId(..), HasUnitId(..)+         , UnitId )+import Distribution.Types.Dependency+         ( Dependency (..), mainLibSet )+import Distribution.Types.GivenComponent+         ( GivenComponent(..) )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint(..), thisPackageVersionConstraint )+import Distribution.Types.MungedPackageId+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription, GenericPackageDescription(..) )+import Distribution.Types.Flag+         ( PackageFlag(..), FlagAssignment, mkFlagAssignment+         , showFlagAssignment, diffFlagAssignment, nullFlagAssignment )+import Distribution.PackageDescription.Configuration+         ( finalizePD )+import Distribution.Version+         ( Version, VersionRange, foldVersionRange )+import Distribution.Simple.Utils as Utils+         ( notice, info, warn, debug, debugNoWrap, die'+         , withTempDirectory )+import Distribution.Client.Utils+         ( determineNumJobs, logDirChange, mergeBy, MergeResult(..)+         , ProgressPhase(..), progressMessage )+import Distribution.System+         ( Platform, OS(Windows), buildOS, buildPlatform )+import Distribution.Verbosity as Verbosity+         ( modifyVerbosity, normal, verbose )+import Distribution.Simple.BuildPaths ( exeExtension )++import qualified Data.ByteString as BS++--TODO:+-- * assign flags to packages individually+--   * complain about flags that do not apply to any package given as target+--     so flags do not apply to dependencies, only listed, can use flag+--     constraints for dependencies+--   * only record applicable flags in world file+-- * allow flag constraints+-- * allow installed constraints+-- * allow flag and installed preferences+-- * change world file to use cabal section syntax+--   * allow persistent configure flags for each package individually++-- ------------------------------------------------------------+-- * Top level user actions+-- ------------------------------------------------------------++-- | Installs the packages needed to satisfy a list of dependencies.+--+install+  :: Verbosity+  -> PackageDBStack+  -> RepoContext+  -> Compiler+  -> Platform+  -> ProgramDb+  -> GlobalFlags+  -> ConfigFlags+  -> ConfigExFlags+  -> InstallFlags+  -> HaddockFlags+  -> TestFlags+  -> BenchmarkFlags+  -> [UserTarget]+  -> IO ()+install verbosity packageDBs repos comp platform progdb+  globalFlags configFlags configExFlags installFlags+  haddockFlags testFlags benchmarkFlags userTargets0 = do++    unless (installRootCmd installFlags == Cabal.NoFlag) $+        warn verbosity $ "--root-cmd is no longer supported, "+        ++ "see https://github.com/haskell/cabal/issues/3353"+        ++ " (if you didn't type --root-cmd, comment out root-cmd"+        ++ " in your ~/.cabal/config file)"+    let userOrSandbox = fromFlag (configUserInstall configFlags)+    unless userOrSandbox $+        warn verbosity $ "the --global flag is deprecated -- "+        ++ "it is generally considered a bad idea to install packages "+        ++ "into the global store"++    installContext <- makeInstallContext verbosity args (Just userTargets0)+    planResult     <- foldProgress logMsg (return . Left) (return . Right) =<<+                      makeInstallPlan verbosity args installContext++    case planResult of+        Left message -> do+            reportPlanningFailure verbosity args installContext message+            die'' message+        Right installPlan ->+            processInstallPlan verbosity args installContext installPlan+  where+    args :: InstallArgs+    args = (packageDBs, repos, comp, platform, progdb,+            globalFlags, configFlags, configExFlags,+            installFlags, haddockFlags, testFlags, benchmarkFlags)++    die'' = die' verbosity++    logMsg message rest = debugNoWrap verbosity message >> rest++-- TODO: Make InstallContext a proper data type with documented fields.+-- | Common context for makeInstallPlan and processInstallPlan.+type InstallContext = ( InstalledPackageIndex, SourcePackageDb+                      , PkgConfigDb+                      , [UserTarget], [PackageSpecifier UnresolvedSourcePackage]+                      , HttpTransport )++-- 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+                   , RepoContext+                   , Compiler+                   , Platform+                   , ProgramDb+                   , GlobalFlags+                   , ConfigFlags+                   , ConfigExFlags+                   , InstallFlags+                   , HaddockFlags+                   , TestFlags+                   , BenchmarkFlags )++-- | Make an install context given install arguments.+makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]+                      -> IO InstallContext+makeInstallContext verbosity+  (packageDBs, repoCtxt, comp, _, progdb,+   globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do++    let idxState = flagToMaybe (installIndexState installFlags)++    installedPkgIndex   <- getInstalledPackages verbosity comp packageDBs progdb+    (sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing+    pkgConfigDb         <- readPkgConfigDb      verbosity progdb++    checkConfigExFlags verbosity installedPkgIndex+                       (packageIndex sourcePkgDb) configExFlags+    transport <- repoContextGetTransport repoCtxt++    (userTargets, pkgSpecifiers) <- case mUserTargets of+      Nothing           ->+        -- We want to distinguish between the case where the user has given an+        -- empty list of targets on the command-line and the case where we+        -- specifically want to have an empty list of targets.+        return ([], [])+      Just userTargets0 -> do+        -- For install, if no target is given it means we use the current+        -- directory as the single target.+        let userTargets | null userTargets0 = [UserTargetLocalDir "."]+                        | otherwise         = userTargets0++        pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                         (fromFlag $ globalWorldFile globalFlags)+                         (packageIndex sourcePkgDb)+                         userTargets+        return (userTargets, pkgSpecifiers)++    return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets+           ,pkgSpecifiers, transport)++-- | Make an install plan given install context and install arguments.+makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext+                -> IO (Progress String String SolverInstallPlan)+makeInstallPlan verbosity+  (_, _, comp, platform,_,+   _, configFlags, configExFlags, installFlags,+   _, _, _)+  (installedPkgIndex, sourcePkgDb, pkgConfigDb,+   _, pkgSpecifiers, _) = do++    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))+              (compilerInfo comp)+    notice verbosity "Resolving dependencies..."+    return $ planPackages verbosity comp platform solver+          configFlags configExFlags installFlags+          installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers++-- | Given an install plan, perform the actual installations.+processInstallPlan :: Verbosity -> InstallArgs -> InstallContext+                   -> SolverInstallPlan+                   -> IO ()+processInstallPlan verbosity+  args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _)+  (installedPkgIndex, sourcePkgDb, _,+   userTargets, pkgSpecifiers, _) installPlan0 = do++    checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb+      installFlags pkgSpecifiers++    unless (dryRun || nothingToInstall) $ do+      buildOutcomes <- performInstallations verbosity+                       args installedPkgIndex installPlan+      postInstallActions verbosity args userTargets installPlan buildOutcomes+  where+    installPlan = InstallPlan.configureInstallPlan configFlags installPlan0+    dryRun = fromFlag (installDryRun installFlags)+    nothingToInstall = null (fst (InstallPlan.ready installPlan))++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Verbosity+             -> Compiler+             -> Platform+             -> Solver+             -> ConfigFlags+             -> ConfigExFlags+             -> InstallFlags+             -> InstalledPackageIndex+             -> SourcePackageDb+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> Progress String String SolverInstallPlan+planPackages verbosity comp platform solver+             configFlags configExFlags installFlags+             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =++        resolveDependencies+          platform (compilerInfo comp) pkgConfigDb+          solver+          resolverParams++    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return++  where+    resolverParams =++        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setCountConflicts countConflicts++      . setFineGrainedConflicts fineGrainedConflicts++      . setMinimizeConflictSet minimizeConflictSet++      . setAvoidReinstalls avoidReinstalls++      . setShadowPkgs shadowPkgs++      . setStrongFlags strongFlags++      . setAllowBootLibInstalls allowBootLibInstalls++      . setOnlyConstrained onlyConstrained++      . setSolverVerbosity verbosity++      . setPreferenceDefault (if upgradeDeps then PreferAllLatest+                                             else PreferLatestForSelected)++      . removeLowerBounds allowOlder+      . removeUpperBounds allowNewer++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | PackageVersionConstraint name ver <- configPreferences configExFlags ]++      . addConstraints+          -- version constraints from the config file or command line+            [ LabeledPackageConstraint (userToPackageConstraint pc) src+            | (pc, src) <- configExConstraints configExFlags ]++      . addConstraints+          --FIXME: this just applies all flags to all targets which+          -- is silly. We should check if the flags are appropriate+          [ let pc = PackageConstraint+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)+                     (PackagePropertyFlags flags)+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+          | let flags = configConfigurationsFlags configFlags+          , not (nullFlagAssignment flags)+          , pkgSpecifier <- pkgSpecifiers ]++      . addConstraints+          [ let pc = PackageConstraint+                     (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)+                     (PackagePropertyStanzas stanzas)+            in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget+          | pkgSpecifier <- pkgSpecifiers ]++      . (if reinstall then reinstallTargets else id)++        -- Don't solve for executables, the legacy install codepath+        -- doesn't understand how to install them+      . setSolveExecutables (SolveExecutables False)++      $ standardInstallPolicy+        installedPkgIndex sourcePkgDb pkgSpecifiers++    stanzas           = [ TestStanzas | testsEnabled ]+                     ++ [ BenchStanzas | benchmarksEnabled ]+    testsEnabled      = fromFlagOrDefault False $ configTests configFlags+    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags++    reinstall        = fromFlag (installOverrideReinstall installFlags) ||+                       fromFlag (installReinstall         installFlags)+    reorderGoals     = fromFlag (installReorderGoals      installFlags)+    countConflicts   = fromFlag (installCountConflicts    installFlags)+    fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags)+    minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags)+    independentGoals = fromFlag (installIndependentGoals  installFlags)+    avoidReinstalls  = fromFlag (installAvoidReinstalls   installFlags)+    shadowPkgs       = fromFlag (installShadowPkgs        installFlags)+    strongFlags      = fromFlag (installStrongFlags       installFlags)+    maxBackjumps     = fromFlag (installMaxBackjumps      installFlags)+    allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)+    onlyConstrained  = fromFlag (installOnlyConstrained   installFlags)+    upgradeDeps      = fromFlag (installUpgradeDeps       installFlags)+    onlyDeps         = fromFlag (installOnlyDeps          installFlags)++    allowOlder       = fromMaybe (AllowOlder mempty)+                                 (configAllowOlder configExFlags)+    allowNewer       = fromMaybe (AllowNewer mempty)+                                 (configAllowNewer configExFlags)++-- | Remove the provided targets from the install plan.+pruneInstallPlan :: Package targetpkg+                 => [PackageSpecifier targetpkg]+                 -> SolverInstallPlan+                 -> Progress String String SolverInstallPlan+pruneInstallPlan pkgSpecifiers =+  -- TODO: this is a general feature and should be moved to D.C.Dependency+  -- Also, the InstallPlan.remove should return info more precise to the+  -- problem, rather than the very general PlanProblem type.+  either (Fail . explain) Done+  . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)+  where+    explain :: [SolverInstallPlan.SolverPlanProblem] -> String+    explain problems =+      "Cannot select only the dependencies (as requested by the "+      ++ "'--only-dependencies' flag), "+      ++ (case pkgids of+             [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "+             _       -> "the packages "+                        ++ intercalate ", " (map prettyShow pkgids) ++ " are ")+      ++ "required by a dependency of one of the other targets."+      where+        pkgids =+          nub [ depid+              | SolverInstallPlan.PackageMissingDeps _ depids <- problems+              , depid <- depids+              , packageName depid `elem` targetnames ]++    targetnames  = map pkgSpecifierTarget pkgSpecifiers++-- ------------------------------------------------------------+-- * Informational messages+-- ------------------------------------------------------------++-- | Perform post-solver checks of the install plan and print it if+-- either requested or needed.+checkPrintPlan :: Verbosity+               -> InstalledPackageIndex+               -> InstallPlan+               -> SourcePackageDb+               -> InstallFlags+               -> [PackageSpecifier UnresolvedSourcePackage]+               -> IO ()+checkPrintPlan verbosity installed installPlan sourcePkgDb+  installFlags pkgSpecifiers = do++  -- User targets that are already installed.+  let preExistingTargets =+        [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,+              InstallPlan.PreExisting p <- InstallPlan.toList installPlan,+              packageName p `elem` tgts ]++  -- If there's nothing to install, we print the already existing+  -- target packages as an explanation.+  when nothingToInstall $+    notice verbosity $ unlines $+         "All the requested packages are already installed:"+       : map (prettyShow . packageId) preExistingTargets+      ++ ["Use --reinstall if you want to reinstall anyway."]++  let lPlan =+        [ (pkg, status)+        | pkg <- InstallPlan.executionOrder installPlan+        , let status = packageStatus installed pkg ]+  -- Are any packages classified as reinstalls?+  let reinstalledPkgs =+        [ ipkg+        | (_pkg, status) <- lPlan+        , ipkg <- extractReinstalls status ]+  -- Packages that are already broken.+  let oldBrokenPkgs =+          map Installed.installedUnitId+        . PackageIndex.reverseDependencyClosure installed+        . map (Installed.installedUnitId . fst)+        . PackageIndex.brokenPackages+        $ installed+  let excluded = reinstalledPkgs ++ oldBrokenPkgs+  -- Packages that are reverse dependencies of replaced packages are very+  -- likely to be broken. We exclude packages that are already broken.+  let newBrokenPkgs =+        filter (\ p -> not (Installed.installedUnitId p `elem` excluded))+               (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)+  let containsReinstalls = not (null reinstalledPkgs)+  let breaksPkgs         = not (null newBrokenPkgs)++  let adaptedVerbosity+        | containsReinstalls+        , not overrideReinstall  = modifyVerbosity (max verbose) verbosity+        | otherwise              = verbosity++  -- We print the install plan if we are in a dry-run or if we are confronted+  -- with a dangerous install plan.+  when (dryRun || containsReinstalls && not overrideReinstall) $+    printPlan (dryRun || breaksPkgs && not overrideReinstall)+      adaptedVerbosity lPlan sourcePkgDb++  -- If the install plan is dangerous, we print various warning messages. In+  -- particular, if we can see that packages are likely to be broken, we even+  -- bail out (unless installation has been forced with --force-reinstalls).+  when containsReinstalls $ do+    if breaksPkgs+      then do+        (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $+            "The following packages are likely to be broken by the reinstalls:"+          : map (prettyShow . mungedId) newBrokenPkgs+          ++ if overrideReinstall+               then if dryRun then [] else+                 ["Continuing even though " +++                  "the plan contains dangerous reinstalls."]+               else+                 ["Use --force-reinstalls if you want to install anyway."]+      else unless dryRun $ warn verbosity+             "Note that reinstalls are always dangerous. Continuing anyway..."++  -- If we are explicitly told to not download anything, check that all packages+  -- are already fetched.+  let offline = fromFlagOrDefault False (installOfflineMode installFlags)+  when offline $ do+    let pkgs = [ confPkgSource cpkg+               | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ]+    notFetched <- fmap (map packageId)+                  . filterM (fmap isNothing . checkFetched . srcpkgSource)+                  $ pkgs+    unless (null notFetched) $+      die' verbosity $ "Can't download packages in offline mode. "+      ++ "Must download the following packages to proceed:\n"+      ++ intercalate ", " (map prettyShow notFetched)+      ++ "\nTry using 'cabal fetch'."++  where+    nothingToInstall = null (fst (InstallPlan.ready installPlan))++    dryRun            = fromFlag (installDryRun            installFlags)+    overrideReinstall = fromFlag (installOverrideReinstall installFlags)++data PackageStatus = NewPackage+                   | NewVersion [Version]+                   | Reinstall  [UnitId] [PackageChange]++type PackageChange = MergeResult MungedPackageId MungedPackageId++extractReinstalls :: PackageStatus -> [UnitId]+extractReinstalls (Reinstall ipids _) = ipids+extractReinstalls _                   = []++packageStatus :: InstalledPackageIndex+              -> ReadyPackage+              -> PackageStatus+packageStatus installedPkgIndex cpkg =+  case PackageIndex.lookupPackageName installedPkgIndex+                                      (packageName cpkg) of+    [] -> NewPackage+    ps ->  case filter ((== mungedId cpkg)+                        . mungedId) (concatMap snd ps) of+      []           -> NewVersion (map fst ps)+      pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs)+                                (changes pkg cpkg)++  where++    changes :: Installed.InstalledPackageInfo+            -> ReadyPackage+            -> [PackageChange]+    changes pkg (ReadyPackage pkg') = filter changed $+      mergeBy (comparing mungedName)+        -- deps of installed pkg+        (resolveInstalledIds $ Installed.depends pkg)+        -- deps of configured pkg+        (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))++    -- convert to source pkg ids via index+    resolveInstalledIds :: [UnitId] -> [MungedPackageId]+    resolveInstalledIds =+        nub+      . sort+      . map mungedId+      . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex)++    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'+    changed _                        = True++printPlan :: Bool -- is dry run+          -> Verbosity+          -> [(ReadyPackage, PackageStatus)]+          -> SourcePackageDb+          -> IO ()+printPlan dryRun verbosity plan sourcePkgDb = case plan of+  []   -> return ()+  pkgs+    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+        ("In order, the following " ++ wouldWill ++ " be installed:")+      : map showPkgAndReason pkgs+    | otherwise -> notice verbosity $ unlines $+        ("In order, the following " ++ wouldWill+         ++ " be installed (use -v for more details):")+      : map showPkg pkgs+  where+    wouldWill | dryRun    = "would"+              | otherwise = "will"++    showPkg (pkg, _) = prettyShow (packageId pkg) +++                       showLatest (pkg)++    showPkgAndReason (ReadyPackage pkg', pr) = unwords+        [ prettyShow (packageId pkg')+        , showLatest pkg'+        , showFlagAssignment (nonDefaultFlags pkg')+        , showStanzas (confPkgStanzas pkg')+        , showDep pkg'+        , case pr of+            NewPackage     -> "(new package)"+            NewVersion _   -> "(new version)"+            Reinstall _ cs -> "(reinstall)" ++ case cs of+                []   -> ""+                diff -> "(changes: "  ++ intercalate ", " (map change diff)+                        ++ ")"+        ]++    showLatest :: Package srcpkg => srcpkg -> String+    showLatest pkg = case mLatestVersion of+        Just latestVersion ->+            if packageVersion pkg < latestVersion+            then ("(latest: " ++ prettyShow latestVersion ++ ")")+            else ""+        Nothing -> ""+      where+        mLatestVersion :: Maybe Version+        mLatestVersion = fmap packageVersion $+                         safeLast $+                         SourcePackageIndex.lookupPackageName+                           (packageIndex sourcePkgDb)+                           (packageName pkg)++    toFlagAssignment :: [PackageFlag] -> FlagAssignment+    toFlagAssignment =  mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))++    nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment+    nonDefaultFlags cpkg =+      let defaultAssignment =+            toFlagAssignment+             (genPackageFlags (SourcePackage.srcpkgDescription $+                               confPkgSource cpkg))+      in  confPkgFlags cpkg `diffFlagAssignment` defaultAssignment++    change (OnlyInLeft pkgid)        = prettyShow pkgid ++ " removed"+    change (InBoth     pkgid pkgid') = prettyShow pkgid ++ " -> "+                                    ++ prettyShow (mungedVersion pkgid')+    change (OnlyInRight      pkgid') = prettyShow pkgid' ++ " added"++    showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps+                  = " (via: " ++ unwords (map prettyShow rdeps) ++  ")"+                | otherwise = ""++    revDepGraphEdges :: [(PackageId, PackageId)]+    revDepGraphEdges = [ (rpid, packageId cpkg)+                       | (ReadyPackage cpkg, _) <- plan+                       , ConfiguredId+                           rpid+                           (Just+                             (PackageDescription.CLibName+                               PackageDescription.LMainLibName))+                           _+                        <- CD.flatDeps (confPkgDeps cpkg) ]++    revDeps :: Map.Map PackageId [PackageId]+    revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges)++-- ------------------------------------------------------------+-- * Post installation stuff+-- ------------------------------------------------------------++-- | Report a solver failure. This works slightly differently to+-- 'postInstallActions', as (by definition) we don't have an install plan.+reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String+                      -> IO ()+reportPlanningFailure verbosity+  (_, _, comp, platform, _+  ,_, configFlags, _, installFlags, _, _, _)+  (_, sourcePkgDb, _, _, pkgSpecifiers, _)+  message = do++  when reportFailure $ do++    -- Only create reports for explicitly named packages+    let pkgids = filter+          (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $+          mapMaybe theSpecifiedPackage pkgSpecifiers++        buildReports = BuildReports.fromPlanningFailure platform+                       (compilerId comp) pkgids+                       (configConfigurationsFlags configFlags)++    unless (null buildReports) $+      info verbosity $+        "Solver failure will be reported for "+        ++ intercalate "," (map prettyShow pkgids)++    -- Save reports+    BuildReports.storeLocal (compilerInfo comp)+                            (fromNubList $ installSummaryFile installFlags)+                            buildReports platform++    -- Save solver log+    case logFile of+      Nothing -> return ()+      Just template -> for_ pkgids $ \pkgid ->+        let env = initialPathTemplateEnv pkgid dummyIpid+                    (compilerInfo comp) platform+            path = fromPathTemplate $ substPathTemplate env template+        in  writeFile path message++  where+    reportFailure = fromFlag (installReportPlanningFailure installFlags)+    logFile = flagToMaybe (installLogFile installFlags)++    -- A IPID is calculated from the transitive closure of+    -- dependencies, but when the solver fails we don't have that.+    -- So we fail.+    dummyIpid = error "reportPlanningFailure: installed package ID not available"++-- | If a 'PackageSpecifier' refers to a single package, return Just that+-- package.+theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId+theSpecifiedPackage pkgSpec =+  case pkgSpec of+    NamedPackage name [PackagePropertyVersion version]+      -> PackageIdentifier name <$> trivialRange version+    NamedPackage _ _ -> Nothing+    SpecificSourcePackage pkg -> Just $ packageId pkg+  where+    -- | If a range includes only a single version, return Just that version.+    trivialRange :: VersionRange -> Maybe Version+    trivialRange = foldVersionRange+        Nothing+        Just     -- "== v"+        (\_ -> Nothing)+        (\_ -> Nothing)+        (\_ _ -> Nothing)+        (\_ _ -> Nothing)++-- | Various stuff we do after successful or unsuccessfully installing a bunch+-- of packages. This includes:+--+--  * build reporting, local and remote+--  * symlinking binaries+--  * updating indexes+--  * updating world file+--  * error reporting+--+postInstallActions :: Verbosity+                   -> InstallArgs+                   -> [UserTarget]+                   -> InstallPlan+                   -> BuildOutcomes+                   -> IO ()+postInstallActions verbosity+  (packageDBs, _, comp, platform, progdb+  ,globalFlags, configFlags, _, installFlags, _, _, _)+  targets installPlan buildOutcomes = do++  unless oneShot $+    World.insert verbosity worldFile+      --FIXME: does not handle flags+      [ World.WorldPkgInfo (Dependency pn vr mainLibSet) mempty+      | UserTargetNamed (PackageVersionConstraint pn vr) <- targets ]++  let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)+                                                  installPlan buildOutcomes+  BuildReports.storeLocal (compilerInfo comp)+                          (fromNubList $ installSummaryFile installFlags)+                          buildReports+                          platform+  when (reportingLevel >= AnonymousReports) $+    BuildReports.storeAnonymous buildReports+  when (reportingLevel == DetailedReports) $+    storeDetailedBuildReports verbosity logsDir buildReports++  regenerateHaddockIndex verbosity packageDBs comp platform progdb+                         configFlags installFlags buildOutcomes++  symlinkBinaries verbosity platform comp configFlags installFlags+                  installPlan buildOutcomes++  printBuildFailures verbosity buildOutcomes++  where+    reportingLevel = fromFlag (installBuildReports installFlags)+    logsDir        = fromFlag (globalLogsDir globalFlags)+    oneShot        = fromFlag (installOneShot installFlags)+    worldFile      = fromFlag $ globalWorldFile globalFlags++storeDetailedBuildReports :: Verbosity -> FilePath+                          -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()+storeDetailedBuildReports verbosity logsDir reports = sequence_+  [ do dotCabal <- getCabalDir+       let logFileName = prettyShow (BuildReports.package report) <.> "log"+           logFile     = logsDir </> logFileName+           reportsDir  = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)+           reportFile  = reportsDir </> logFileName++       handleMissingLogFile $ do+         buildLog <- readFile logFile+         createDirectoryIfMissing True reportsDir -- FIXME+         writeFile reportFile (show (showBuildReport report, buildLog))++  | (report, Just repo) <- reports+  , Just remoteRepo <- [maybeRepoRemote repo]+  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]++  where+    isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True+    isLikelyToHaveLogFile BuildReports.BuildFailed     {} = True+    isLikelyToHaveLogFile BuildReports.InstallFailed   {} = True+    isLikelyToHaveLogFile BuildReports.InstallOk       {} = True+    isLikelyToHaveLogFile _                               = False++    handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->+      warn verbosity $ "Missing log file for build report: "+                    ++ fromMaybe ""  (ioeGetFileName ioe)++    missingFile ioe+      | isDoesNotExistError ioe  = Just ioe+    missingFile _                = Nothing+++regenerateHaddockIndex :: Verbosity+                       -> [PackageDB]+                       -> Compiler+                       -> Platform+                       -> ProgramDb+                       -> ConfigFlags+                       -> InstallFlags+                       -> BuildOutcomes+                       -> IO ()+regenerateHaddockIndex verbosity packageDBs comp platform progdb+                       configFlags installFlags buildOutcomes+  | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   (compilerFlavor comp)+                   (fromFlag (configUserInstall configFlags))+                   True+  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)+      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate++  notice verbosity $+     "Updating documentation index " ++ indexFile++  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+  Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile++  | otherwise = return ()+  where+    haddockIndexFileIsRequested =+         fromFlag (installDocumentation installFlags)+      && isJust (flagToMaybe (installHaddockIndex installFlags))++    -- We want to regenerate the index if some new documentation was actually+    -- installed. Since the index can be only per-user or per-sandbox (see+    -- #1337), we don't do it for global installs or special cases where we're+    -- installing into a specific db.+    shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes+      where+        someDocsWereInstalled = any installedDocs . Map.elems+        installedDocs (Right (BuildResult DocsOk _ _)) = True+        installedDocs _                                = False++        normalUserInstall     = (UserPackageDB `elem` packageDBs)+                             && all (not . isSpecificPackageDB) packageDBs+        isSpecificPackageDB (SpecificPackageDB _) = True+        isSpecificPackageDB _                     = False++    substHaddockIndexFileName defaultDirs = fromPathTemplate+                                          . substPathTemplate env+      where+        env  = env0 ++ installDirsTemplateEnv absoluteDirs+        env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp)+            ++ InstallDirs.platformTemplateEnv platform+            ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform+        absoluteDirs = InstallDirs.substituteInstallDirTemplates+                         env0 templateDirs+        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                         defaultDirs (configInstallDirs configFlags)+++symlinkBinaries :: Verbosity+                -> Platform -> Compiler+                -> ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> BuildOutcomes+                -> IO ()+symlinkBinaries verbosity platform comp configFlags installFlags+                plan buildOutcomes = do+  failed <- InstallSymlink.symlinkBinaries platform comp+                                           NeverOverwrite+                                           configFlags installFlags+                                           plan buildOutcomes+  case failed of+    [] -> return ()+    [(_, exe, path)] ->+      warn verbosity $+           "could not create a symlink in " ++ bindir ++ " for "+        ++ prettyShow exe ++ " because the file exists there already but is not "+        ++ "managed by cabal. You can create a symlink for this executable "+        ++ "manually if you wish. The executable file has been installed at "+        ++ path+    exes ->+      warn verbosity $+           "could not create symlinks in " ++ bindir ++ " for "+        ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ]+        ++ " because the files exist there already and are not "+        ++ "managed by cabal. You can create symlinks for these executables "+        ++ "manually if you wish. The executable files have been installed at "+        ++ intercalate ", " [ path | (_, _, path) <- exes ]+  where+    bindir = fromFlag (installSymlinkBinDir installFlags)+++printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()+printBuildFailures verbosity buildOutcomes =+  case [ (pkgid, failure)+       | (pkgid, Left failure) <- Map.toList buildOutcomes ] of+    []     -> return ()+    failed -> die' verbosity . unlines+            $ "Error: some packages failed to install:"+            : [ prettyShow pkgid ++ printFailureReason reason+              | (pkgid, reason) <- failed ]+  where+    printFailureReason reason = case reason of+      DependentFailed pkgid -> " depends on " ++ prettyShow pkgid+                            ++ " which failed to install."+      DownloadFailed  e -> " failed while downloading the package."+                        ++ showException e+      UnpackFailed    e -> " failed while unpacking the package."+                        ++ showException e+      ConfigureFailed e -> " failed during the configure step."+                        ++ showException e+      BuildFailed     e -> " failed during the building phase."+                        ++ showException e+      TestsFailed     e -> " failed during the tests phase."+                        ++ showException e+      InstallFailed   e -> " failed during the final install step."+                        ++ showException e++      -- This will never happen, but we include it for completeness+      PlanningFailed -> " failed during the planning phase."++    showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e+#ifdef mingw32_HOST_OS+    maybeOOM _        = ""+#else+    maybeOOM e                    = maybe "" onExitFailure (fromException e)+    onExitFailure (ExitFailure n)+      | n == 9 || n == -9         =+      "\nThis may be due to an out-of-memory condition."+    onExitFailure _               = ""+#endif++-- ------------------------------------------------------------+-- * Actually do the installations+-- ------------------------------------------------------------++data InstallMisc = InstallMisc {+    libVersion :: Maybe Version+  }++-- | If logging is enabled, contains location of the log file and the verbosity+-- level for logging.+type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)++performInstallations :: Verbosity+                     -> InstallArgs+                     -> InstalledPackageIndex+                     -> InstallPlan+                     -> IO BuildOutcomes+performInstallations verbosity+  (packageDBs, repoCtxt, comp, platform, progdb,+   globalFlags, configFlags, configExFlags, installFlags,+   haddockFlags, testFlags, _)+  installedPkgIndex installPlan = do++  info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."++  jobControl   <- if parallelInstall then newParallelJobControl numJobs+                                     else newSerialJobControl+  fetchLimit   <- newJobLimit (min numJobs numFetchJobs)+  installLock  <- newLock -- serialise installation+  cacheLock    <- newLock -- serialise access to setup exe cache++  executeInstallPlan verbosity jobControl keepGoing useLogFile+                     installPlan $ \rpkg ->+    installReadyPackage platform cinfo configFlags+                        rpkg $ \configFlags' src pkg pkgoverride ->+      fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->+        installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->+          installUnpackedPackage verbosity installLock numJobs+                                 (setupScriptOptions installedPkgIndex+                                  cacheLock rpkg)+                                 configFlags'+                                 installFlags haddockFlags testFlags+                                 comp progdb+                                 platform pkg rpkg pkgoverride mpath useLogFile++  where+    cinfo = compilerInfo comp++    numJobs         = determineNumJobs (installNumJobs installFlags)+    numFetchJobs    = 2+    parallelInstall = numJobs >= 2+    keepGoing       = fromFlag (installKeepGoing installFlags)+    distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                      (configDistPref configFlags)++    setupScriptOptions index lock rpkg =+      configureSetupScript+        packageDBs+        comp+        platform+        progdb+        distPref+        (chooseCabalVersion configExFlags (libVersion miscOptions))+        (Just lock)+        parallelInstall+        index+        (Just rpkg)++    reportingLevel = fromFlag (installBuildReports installFlags)+    logsDir        = fromFlag (globalLogsDir globalFlags)++    -- Should the build output be written to a log file instead of stdout?+    useLogFile :: UseLogFile+    useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)+                 logFileTemplate+      where+        installLogFile' = flagToMaybe $ installLogFile installFlags+        defaultTemplate = toPathTemplate $+                            logsDir </> "$compiler" </> "$libname" <.> "log"++        -- If the user has specified --remote-build-reporting=detailed, use the+        -- default log file location. If the --build-log option is set, use the+        -- provided location. Otherwise don't use logging, unless building in+        -- parallel (in which case the default location is used).+        logFileTemplate :: Maybe PathTemplate+        logFileTemplate+          | useDefaultTemplate = Just defaultTemplate+          | otherwise          = installLogFile'++        -- If the user has specified --remote-build-reporting=detailed or+        -- --build-log, use more verbose logging.+        loggingVerbosity :: Verbosity+        loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity+                         | otherwise         = verbosity++        useDefaultTemplate :: Bool+        useDefaultTemplate+          | reportingLevel == DetailedReports = True+          | isJust installLogFile'            = False+          | parallelInstall                   = True+          | otherwise                         = False++        overrideVerbosity :: Bool+        overrideVerbosity+          | reportingLevel == DetailedReports = True+          | isJust installLogFile'            = True+          | parallelInstall                   = False+          | otherwise                         = False++    substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath+    substLogFileName template pkg uid = fromPathTemplate+                                  . substPathTemplate env+                                  $ template+      where env = initialPathTemplateEnv (packageId pkg) uid+                    (compilerInfo comp) platform++    miscOptions  = InstallMisc {+      libVersion = flagToMaybe (configCabalVersion configExFlags)+    }+++executeInstallPlan :: Verbosity+                   -> JobControl IO (UnitId, BuildOutcome)+                   -> Bool+                   -> UseLogFile+                   -> InstallPlan+                   -> (ReadyPackage -> IO BuildOutcome)+                   -> IO BuildOutcomes+executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =+    InstallPlan.execute+      jobCtl keepGoing depsFailure plan0 $ \pkg -> do+        buildOutcome <- installPkg pkg+        printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome+        return buildOutcome++  where+    depsFailure = DependentFailed . packageId++    -- Print build log if something went wrong, and 'Installed $PKGID'+    -- otherwise.+    printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()+    printBuildResult pkgid uid buildOutcome = case buildOutcome of+        (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid)+        (Left _)  -> do+          notice verbosity $ "Failed to install " ++ prettyShow pkgid+          when (verbosity >= normal) $+            case useLogFile of+              Nothing                 -> return ()+              Just (mkLogFileName, _) -> do+                let logName = mkLogFileName pkgid uid+                putStr $ "Build log ( " ++ logName ++ " ):\n"+                printFile logName++    printFile :: FilePath -> IO ()+    printFile path = readFile path >>= putStr++-- | Call an installer for an 'SourcePackage' but override the configure+-- 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+-- 'configurePackage' in D.C.Configure.+installReadyPackage :: Platform -> CompilerInfo+                    -> ConfigFlags+                    -> ReadyPackage+                    -> (ConfigFlags -> UnresolvedPkgLoc+                                    -> PackageDescription+                                    -> PackageDescriptionOverride+                                    -> a)+                    -> a+installReadyPackage platform cinfo configFlags+                    (ReadyPackage (ConfiguredPackage ipid+                                    (SourcePackage _ gpkg source pkgoverride)+                                    flags stanzas deps))+                    installPkg =+  installPkg configFlags {+    configIPID = toFlag (prettyShow ipid),+    configConfigurationsFlags = flags,+    -- 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  = [ thisPackageVersionConstraint srcid+                         | ConfiguredId+                             srcid+                             (Just+                               (PackageDescription.CLibName+                                 PackageDescription.LMainLibName))+                             _ipid+                            <- CD.nonSetupDeps deps ],+    configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid+                         | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid+                            <- CD.nonSetupDeps deps ],+    -- Use '--exact-configuration' if supported.+    configExactConfiguration = toFlag True,+    configBenchmarks         = toFlag False,+    configTests              = toFlag (TestStanzas `optStanzaSetMember` stanzas)+  } source pkg pkgoverride+  where+    pkg = case finalizePD flags (enableStanzas stanzas)+           (const True)+           platform cinfo [] gpkg of+      Left _ -> error "finalizePD ReadyPackage failed"+      Right (desc, _) -> desc++fetchSourcePackage+  :: Verbosity+  -> RepoContext+  -> JobLimit+  -> UnresolvedPkgLoc+  -> (ResolvedPkgLoc -> IO BuildOutcome)+  -> IO BuildOutcome+fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do+  fetched <- checkFetched src+  case fetched of+    Just src' -> installPkg src'+    Nothing   -> onFailure DownloadFailed $ do+                   loc <- withJobLimit fetchLimit $+                            fetchPackage verbosity repoCtxt src+                   installPkg loc+++installLocalPackage+  :: Verbosity+  -> PackageIdentifier -> ResolvedPkgLoc -> FilePath+  -> (Maybe FilePath -> IO BuildOutcome)+  -> IO BuildOutcome+installLocalPackage verbosity pkgid location distPref installPkg =++  case location of++    LocalUnpackedPackage dir ->+      installPkg (Just dir)++    RemoteSourceRepoPackage _repo dir ->+      installPkg (Just dir)++    LocalTarballPackage tarballPath ->+      installLocalTarballPackage verbosity+        pkgid tarballPath distPref installPkg++    RemoteTarballPackage _ tarballPath ->+      installLocalTarballPackage verbosity+        pkgid tarballPath distPref installPkg++    RepoTarballPackage _ _ tarballPath ->+      installLocalTarballPackage verbosity+        pkgid tarballPath distPref installPkg++installLocalTarballPackage+  :: Verbosity+  -> PackageIdentifier -> FilePath -> FilePath+  -> (Maybe FilePath -> IO BuildOutcome)+  -> IO BuildOutcome+installLocalTarballPackage verbosity pkgid+                           tarballPath distPref installPkg = do+  tmp <- getTemporaryDirectory+  withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->+    onFailure UnpackFailed $ do+      let relUnpackedPath = prettyShow pkgid+          absUnpackedPath = tmpDirPath </> relUnpackedPath+          descFilePath = absUnpackedPath+                     </> prettyShow (packageName pkgid) <.> "cabal"+      info verbosity $ "Extracting " ++ tarballPath+                    ++ " to " ++ tmpDirPath ++ "..."+      extractTarGzFile tmpDirPath relUnpackedPath tarballPath+      exists <- doesFileExist descFilePath+      unless exists $+        die' verbosity $ "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 a nonstandard build directory name+    -- is used (as is the case with sandboxes), so we need to rename+    -- the 'dist' dir here.+    --+    -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still+    -- fails even with this workaround. We probably can live with that.+    maybeRenameDistDir :: FilePath -> IO ()+    maybeRenameDistDir absUnpackedPath = do+      let distDirPath    = absUnpackedPath </> defaultDistPref+          distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")+          distDirPathNew = absUnpackedPath </> distPref+      distDirExists <- doesDirectoryExist distDirPath+      when (distDirExists+            && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do+        -- NB: we need to handle the case when 'distDirPathNew' is a+        -- subdirectory of 'distDirPath' (e.g. the former is+        -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').+        debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '"+          ++ distDirPathTmp ++ "'."+        renameDirectory distDirPath distDirPathTmp+        when (distDirPath `isPrefixOf` distDirPathNew) $+          createDirectoryIfMissingVerbose verbosity False distDirPath+        debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '"+          ++ distDirPathNew ++ "'."+        renameDirectory distDirPathTmp distDirPathNew++installUnpackedPackage+  :: Verbosity+  -> Lock+  -> Int+  -> SetupScriptOptions+  -> ConfigFlags+  -> InstallFlags+  -> HaddockFlags+  -> TestFlags+  -> Compiler+  -> ProgramDb+  -> Platform+  -> PackageDescription+  -> ReadyPackage+  -> PackageDescriptionOverride+  -> Maybe FilePath -- ^ Directory to change to before starting the installation.+  -> UseLogFile -- ^ File to log output to (if any)+  -> IO BuildOutcome+installUnpackedPackage verbosity installLock numJobs+                       scriptOptions+                       configFlags installFlags haddockFlags testFlags comp progdb+                       platform pkg rpkg pkgoverride workingDir useLogFile = do+  -- Override the .cabal file if necessary+  case pkgoverride of+    Nothing     -> return ()+    Just pkgtxt -> do+      let descFilePath = fromMaybe "." workingDir+                     </> prettyShow (packageName pkgid) <.> "cabal"+      info verbosity $+        "Updating " ++ prettyShow (packageName pkgid) <.> "cabal"+                    ++ " with the latest revision from the index."+      writeFileAtomic descFilePath pkgtxt++  -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if+  -- the setup script was compiled against an old version of the Cabal lib).+  configFlags' <- addDefaultInstallDirs configFlags+  -- Filter out flags not supported by the old versions of the Cabal lib.+  let configureFlags :: Version -> ConfigFlags+      configureFlags  = filterConfigureFlags configFlags' {+        configVerbosity = toFlag verbosity'+      }++  -- Path to the optional log file.+  mLogPath <- maybeLogPath++  logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do+    -- Configure phase+    onFailure ConfigureFailed $ do+      noticeProgress ProgressStarting+      setup configureCommand configureFlags mLogPath++    -- Build phase+      onFailure BuildFailed $ do+        noticeProgress ProgressBuilding+        setup buildCommand' buildFlags mLogPath++    -- Doc generation phase+        docsResult <- if shouldHaddock+          then (do setup haddockCommand haddockFlags' mLogPath+                   return DocsOk)+                 `catchIO`   (\_ -> return DocsFailed)+                 `catchExit` (\_ -> return DocsFailed)+          else return DocsNotTried++    -- Tests phase+        onFailure TestsFailed $ do+          when (testsEnabled && PackageDescription.hasTests pkg) $+              setup Cabal.testCommand testFlags' mLogPath++          let testsResult | testsEnabled = TestsOk+                          | otherwise = TestsNotTried++        -- Install phase+          onFailure InstallFailed $ criticalSection installLock $ do+            -- Actual installation+            withWin32SelfUpgrade verbosity uid configFlags+                                 cinfo platform pkg $ do+              setup Cabal.copyCommand copyFlags mLogPath++            -- Capture installed package configuration file, so that+            -- it can be incorporated into the final InstallPlan+            ipkgs <- genPkgConfs mLogPath+            let ipkgs' = case ipkgs of+                            [ipkg] -> [ipkg { Installed.installedUnitId = uid }]+                            _ -> ipkgs+            let packageDBs = interpretPackageDbFlags+                                (fromFlag (configUserInstall configFlags))+                                (configPackageDBs configFlags)+            for_ ipkgs' $ \ipkg' ->+                registerPackage verbosity comp progdb+                                packageDBs ipkg'+                                defaultRegisterOptions++            return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs')))++  where+    pkgid            = packageId pkg+    uid              = installedUnitId rpkg+    cinfo            = compilerInfo comp+    buildCommand'    = buildCommand progdb+    dispname         = prettyShow pkgid+    isParallelBuild  = numJobs >= 2++    noticeProgress phase = when isParallelBuild $+        progressMessage verbosity phase dispname++    buildFlags   _   = emptyBuildFlags {+      buildDistPref  = configDistPref configFlags,+      buildVerbosity = toFlag verbosity'+    }+    shouldHaddock    = fromFlag (installDocumentation installFlags)+    haddockFlags' _   = haddockFlags {+      haddockVerbosity = toFlag verbosity',+      haddockDistPref  = configDistPref configFlags+    }+    testsEnabled = fromFlag (configTests configFlags)+                   && fromFlagOrDefault False (installRunTests installFlags)+    testFlags' = filterTestFlags testFlags {+      Cabal.testDistPref = configDistPref configFlags+    }+    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 ++ "-" ++ prettyShow pkgid++    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs configFlags' = do+      defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False+      return $ configFlags' {+          configInstallDirs = fmap Cabal.Flag .+                              InstallDirs.substituteInstallDirTemplates env $+                              InstallDirs.combineInstallDirs fromFlagOrDefault+                              defInstallDirs (configInstallDirs configFlags)+          }+        where+          CompilerId flavor _ = compilerInfoId cinfo+          env         = initialPathTemplateEnv pkgid uid cinfo platform+          userInstall = fromFlagOrDefault defaultUserInstall+                        (configUserInstall configFlags')++    genPkgConfs :: Maybe FilePath+                     -> IO [Installed.InstalledPackageInfo]+    genPkgConfs mLogPath =+      if shouldRegister then do+        tmp <- getTemporaryDirectory+        withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do+          let pkgConfDest = dir </> "pkgConf"+              registerFlags' version = (registerFlags version) {+                Cabal.regGenPkgConf = toFlag (Just pkgConfDest)+              }+          setup Cabal.registerCommand registerFlags' mLogPath+          is_dir <- doesDirectoryExist pkgConfDest+          let notHidden = not . isHidden+              isHidden name = "." `isPrefixOf` name+          if is_dir+            -- Sort so that each prefix of the package+            -- configurations is well formed+            then traverse (readPkgConf pkgConfDest) . sort . filter notHidden+                    =<< getDirectoryContents pkgConfDest+            else fmap (:[]) $ readPkgConf "." pkgConfDest+      else return []++    readPkgConf :: FilePath -> FilePath+                -> IO Installed.InstalledPackageInfo+    readPkgConf pkgConfDir pkgConfFile = do+      pkgConfText <- BS.readFile (pkgConfDir </> pkgConfFile)+      case Installed.parseInstalledPackageInfo pkgConfText of+        Left perrors    -> pkgConfParseFailed $ unlines $ NE.toList perrors+        Right (warns, pkgConf) -> do+          unless (null warns) $+            warn verbosity $ unlines warns+          return pkgConf++    pkgConfParseFailed :: String -> IO a+    pkgConfParseFailed perror =+      die' verbosity $ "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) uid+               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+      (traverse (\path -> openFile path AppendMode) mLogPath)+      (traverse_ hClose)+      (\logFileHandle ->+        setupWrapper verbosity+          scriptOptions { useLoggingHandle = logFileHandle+                        , useWorkingDir    = workingDir }+          (Just pkg)+          cmd flags (const []))+++-- helper+onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome+onFailure result action =+  action `catches`+    [ Handler $ \ioe  -> handler (ioe  :: IOException)+    , Handler $ \exit -> handler (exit :: ExitCode)+    ]+  where+    handler :: Exception e => e -> IO BuildOutcome+    handler = return . Left . result . toException+++-- ------------------------------------------------------------+-- * Weird windows hacks+-- ------------------------------------------------------------++withWin32SelfUpgrade :: Verbosity+                     -> UnitId+                     -> ConfigFlags+                     -> CompilerInfo+                     -> Platform+                     -> PackageDescription+                     -> IO a -> IO a+withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   compFlavor+                   (fromFlag (configUserInstall configFlags))+                   (PackageDescription.hasLibs pkg)++  Win32SelfUpgrade.possibleSelfUpgrade verbosity+    (exeInstallPaths defaultDirs) action++  where+    pkgid = packageId pkg+    (CompilerId compFlavor _) = compilerInfoId cinfo++    exeInstallPaths defaultDirs =+      [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension buildPlatform+      | exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe)+      , let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix+            prefix  = substTemplate prefixTemplate+            suffix  = substTemplate suffixTemplate ]+      where+        fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+        prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)+        suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)+        templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+        absoluteDirs   = InstallDirs.absoluteInstallDirs+                           pkgid uid+                           cinfo InstallDirs.NoCopyDest+                           platform templateDirs+        substTemplate  = InstallDirs.fromPathTemplate+                       . InstallDirs.substPathTemplate env+          where env = InstallDirs.initialPathTemplateEnv pkgid uid+                      cinfo platform
+ src/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,957 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Package installation plan+--+-----------------------------------------------------------------------------+module Distribution.Client.InstallPlan (+  InstallPlan,+  GenericInstallPlan,+  PlanPackage,+  GenericPlanPackage(..),+  foldPlanPackage,+  IsUnit,++  -- * Operations on 'InstallPlan's+  new,+  toGraph,+  toList,+  toMap,+  keys,+  keysSet,+  planIndepGoals,+  depends,++  fromSolverInstallPlan,+  fromSolverInstallPlanWithProgress,+  configureInstallPlan,+  remove,+  installed,+  lookup,+  directDeps,+  revDirectDeps,++  -- * Traversal+  executionOrder,+  execute,+  BuildOutcomes,+  lookupBuildOutcome,+  -- ** Traversal helpers+  -- $traversal+  Processing,+  ready,+  completed,+  failed,++  -- * Display+  showPlanGraph,+  showInstallPlan,++  -- * Graph-like operations+  dependencyClosure,+  reverseTopologicalOrder,+  reverseDependencyClosure,+  ) where++import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail)+import Prelude (tail)+import Distribution.Compat.Stack (WithCallStack)++import Distribution.Client.Types hiding (BuildOutcomes)+import qualified Distribution.PackageDescription as PD+import qualified Distribution.Simple.Configure as Configure+import qualified Distribution.Simple.Setup as Cabal++import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.Package+         ( Package(..), HasMungedPackageId(..)+         , HasUnitId(..), UnitId )+import Distribution.Solver.Types.SolverPackage+import Distribution.Client.JobControl+import Distribution.Pretty (defaultStyle)+import Text.PrettyPrint+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.InstSolverPackage++import           Distribution.Utils.LogProgress+import           Distribution.Utils.Structured (Structured (..), Structure(Nominal))++-- TODO: Need this when we compute final UnitIds+-- import qualified Distribution.Simple.Configure as Configure++import qualified Data.Foldable as Foldable (all, toList)+import qualified Distribution.Compat.Graph as Graph+import Distribution.Compat.Graph (Graph, IsNode(..))+import Control.Exception+         ( assert )+import qualified Data.Map as Map+import qualified Data.Set as Set++-- When cabal tries to install a number of packages, including all their+-- dependencies it has a non-trivial problem to solve.+--+-- The Problem:+--+-- In general we start with a set of installed packages and a set of source+-- packages.+--+-- Installed packages have fixed dependencies. They have already been built and+-- we know exactly what packages they were built against, including their exact+-- versions.+--+-- Source package have somewhat flexible dependencies. They are specified as+-- version ranges, though really they're predicates. To make matters worse they+-- have conditional flexible dependencies. Configuration flags can affect which+-- packages are required and can place additional constraints on their+-- versions.+--+-- These two sets of package can and usually do overlap. There can be installed+-- packages that are also available as source packages which means they could+-- be re-installed if required, though there will also be packages which are+-- not available as source and cannot be re-installed. Very often there will be+-- extra versions available than are installed. Sometimes we may like to prefer+-- installed packages over source ones or perhaps always prefer the latest+-- available version whether installed or not.+--+-- The goal is to calculate an installation plan that is closed, acyclic and+-- consistent and where every configured package is valid.+--+-- An installation plan is a set of packages that are going to be used+-- together. It will consist of a mixture of installed packages and source+-- packages along with their exact version dependencies. An installation plan+-- is closed if for every package in the set, all of its dependencies are+-- also in the set. It is consistent if for every package in the set, all+-- dependencies which target that package have the same version.++-- Note that plans do not necessarily compose. You might have a valid plan for+-- package A and a valid plan for package B. That does not mean the composition+-- is simultaneously valid for A and B. In particular you're most likely to+-- have problems with inconsistent dependencies.+-- On the other hand it is true that every closed sub plan is valid.++-- | Packages in an install plan+--+-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'+-- intentionally have no 'PackageInstalled' instance. `This is important:+-- PackageInstalled returns only library dependencies, but for package that+-- aren't yet installed we know many more kinds of dependencies (setup+-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on+-- dependencies in cabal-install should consider what to do with these+-- dependencies; if we give a 'PackageInstalled' instance it would be too easy+-- to get this wrong (and, for instance, call graph traversal functions from+-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.+data GenericPlanPackage ipkg srcpkg+   = PreExisting ipkg+   | Configured  srcpkg+   | Installed   srcpkg+  deriving (Eq, Show, Generic)++displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String+displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)+displayGenericPlanPackage (Configured pkg)  = "Configured " ++ prettyShow (nodeKey pkg)+displayGenericPlanPackage (Installed pkg)   = "Installed " ++ prettyShow (nodeKey pkg)++-- | Convenience combinator for destructing 'GenericPlanPackage'.+-- This is handy because if you case manually, you have to handle+-- 'Configured' and 'Installed' separately (where often you want+-- them to be the same.)+foldPlanPackage :: (ipkg -> a)+                -> (srcpkg -> a)+                -> GenericPlanPackage ipkg srcpkg+                -> a+foldPlanPackage f _ (PreExisting ipkg)  = f ipkg+foldPlanPackage _ g (Configured srcpkg) = g srcpkg+foldPlanPackage _ g (Installed  srcpkg) = g srcpkg++type IsUnit a = (IsNode a, Key a ~ UnitId)++depends :: IsUnit a => a -> [UnitId]+depends = nodeNeighbors++-- NB: Expanded constraint synonym here to avoid undecidable+-- instance errors in GHC 7.8 and earlier.+instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)+         => IsNode (GenericPlanPackage ipkg srcpkg) where+    type Key (GenericPlanPackage ipkg srcpkg) = UnitId+    nodeKey (PreExisting ipkg) = nodeKey ipkg+    nodeKey (Configured  spkg) = nodeKey spkg+    nodeKey (Installed   spkg) = nodeKey spkg+    nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg+    nodeNeighbors (Configured  spkg) = nodeNeighbors spkg+    nodeNeighbors (Installed   spkg) = nodeNeighbors spkg++instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)+instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg)++type PlanPackage = GenericPlanPackage+                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)++instance (Package ipkg, Package srcpkg) =>+         Package (GenericPlanPackage ipkg srcpkg) where+  packageId (PreExisting ipkg)     = packageId ipkg+  packageId (Configured  spkg)     = packageId spkg+  packageId (Installed   spkg)     = packageId spkg++instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) =>+         HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where+  mungedId (PreExisting ipkg)     = mungedId ipkg+  mungedId (Configured  spkg)     = mungedId spkg+  mungedId (Installed   spkg)     = mungedId spkg++instance (HasUnitId ipkg, HasUnitId srcpkg) =>+         HasUnitId+         (GenericPlanPackage ipkg srcpkg) where+  installedUnitId (PreExisting ipkg) = installedUnitId ipkg+  installedUnitId (Configured  spkg) = installedUnitId spkg+  installedUnitId (Installed   spkg) = installedUnitId spkg++instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>+          HasConfiguredId (GenericPlanPackage ipkg srcpkg) where+    configuredId (PreExisting ipkg) = configuredId ipkg+    configuredId (Configured  spkg) = configuredId spkg+    configuredId (Installed   spkg) = configuredId spkg++data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {+    planGraph      :: !(Graph (GenericPlanPackage ipkg srcpkg)),+    planIndepGoals :: !IndependentGoals+  }+  deriving (Typeable)++-- | 'GenericInstallPlan' specialised to most commonly used types.+type InstallPlan = GenericInstallPlan+                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)++-- | Smart constructor that deals with caching the 'Graph' representation.+--+mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)+              => String+              -> Graph (GenericPlanPackage ipkg srcpkg)+              -> IndependentGoals+              -> GenericInstallPlan ipkg srcpkg+mkInstallPlan loc graph indepGoals =+    assert (valid loc graph)+    GenericInstallPlan {+      planGraph      = graph,+      planIndepGoals = indepGoals+    }++internalError :: WithCallStack (String -> String -> a)+internalError loc msg = error $ "internal error in InstallPlan." ++ loc+                             ++ if null msg then "" else ": " ++ msg++instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where+    structure p = Nominal (typeRep p) 0 "GenericInstallPlan"+        [ structure (Proxy :: Proxy ipkg)+        , structure (Proxy :: Proxy srcpkg)+        ]++instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,+          Binary ipkg, Binary srcpkg)+       => Binary (GenericInstallPlan ipkg srcpkg) where+    put GenericInstallPlan {+              planGraph      = graph,+              planIndepGoals = indepGoals+        } = put graph >> put indepGoals++    get = do+      graph <- get+      indepGoals <- get+      return $! mkInstallPlan "(instance Binary)" graph indepGoals++showPlanGraph :: (Package ipkg, Package srcpkg,+                  IsUnit ipkg, IsUnit srcpkg)+              => Graph (GenericPlanPackage ipkg srcpkg) -> String+showPlanGraph graph = renderStyle defaultStyle $+    vcat (map dispPlanPackage (Foldable.toList graph))+  where dispPlanPackage p =+            hang (hsep [ text (showPlanPackageTag p)+                       , pretty (packageId p)+                       , parens (pretty (nodeKey p))]) 2+                 (vcat (map pretty (nodeNeighbors p)))++showInstallPlan :: (Package ipkg, Package srcpkg,+                    IsUnit ipkg, IsUnit srcpkg)+                => GenericInstallPlan ipkg srcpkg -> String+showInstallPlan = showPlanGraph . planGraph++showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String+showPlanPackageTag (PreExisting _)   = "PreExisting"+showPlanPackageTag (Configured  _)   = "Configured"+showPlanPackageTag (Installed   _)   = "Installed"++-- | Build an installation plan from a valid set of resolved packages.+--+new :: (IsUnit ipkg, IsUnit srcpkg)+    => IndependentGoals+    -> Graph (GenericPlanPackage ipkg srcpkg)+    -> GenericInstallPlan ipkg srcpkg+new indepGoals graph = mkInstallPlan "new" graph indepGoals++toGraph :: GenericInstallPlan ipkg srcpkg+        -> Graph (GenericPlanPackage ipkg srcpkg)+toGraph = planGraph++toList :: GenericInstallPlan ipkg srcpkg+       -> [GenericPlanPackage ipkg srcpkg]+toList = Foldable.toList . planGraph++toMap :: GenericInstallPlan ipkg srcpkg+      -> Map UnitId (GenericPlanPackage ipkg srcpkg)+toMap = Graph.toMap . planGraph++keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]+keys = Graph.keys . planGraph++keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId+keysSet = Graph.keysSet . planGraph++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (IsUnit ipkg, IsUnit srcpkg)+       => (GenericPlanPackage ipkg srcpkg -> Bool)+       -> GenericInstallPlan ipkg srcpkg+       -> GenericInstallPlan ipkg srcpkg+remove shouldRemove plan =+    mkInstallPlan "remove" newGraph (planIndepGoals plan)+  where+    newGraph = Graph.fromDistinctList $+                 filter (not . shouldRemove) (toList plan)++-- | Change a number of packages in the 'Configured' state to the 'Installed'+-- state.+--+-- To preserve invariants, the package must have all of its dependencies+-- already installed too (that is 'PreExisting' or 'Installed').+--+installed :: (IsUnit ipkg, IsUnit srcpkg)+          => (srcpkg -> Bool)+          -> GenericInstallPlan ipkg srcpkg+          -> GenericInstallPlan ipkg srcpkg+installed shouldBeInstalled installPlan =+    foldl' markInstalled installPlan+      [ pkg+      | Configured pkg <- reverseTopologicalOrder installPlan+      , shouldBeInstalled pkg ]+  where+    markInstalled plan pkg =+      assert (all isInstalled (directDeps plan (nodeKey pkg))) $+      plan {+        planGraph = Graph.insert (Installed pkg) (planGraph plan)+      }++-- | Lookup a package in the plan.+--+lookup :: (IsUnit ipkg, IsUnit srcpkg)+       => GenericInstallPlan ipkg srcpkg+       -> UnitId+       -> Maybe (GenericPlanPackage ipkg srcpkg)+lookup plan pkgid = Graph.lookup pkgid (planGraph plan)++-- | Find all the direct dependencies of the given package.+--+-- Note that the package must exist in the plan or it is an error.+--+directDeps :: GenericInstallPlan ipkg srcpkg+           -> UnitId+           -> [GenericPlanPackage ipkg srcpkg]+directDeps plan pkgid =+  case Graph.neighbors (planGraph plan) pkgid of+    Just deps -> deps+    Nothing   -> internalError "directDeps" "package not in graph"++-- | Find all the direct reverse dependencies of the given package.+--+-- Note that the package must exist in the plan or it is an error.+--+revDirectDeps :: GenericInstallPlan ipkg srcpkg+              -> UnitId+              -> [GenericPlanPackage ipkg srcpkg]+revDirectDeps plan pkgid =+  case Graph.revNeighbors (planGraph plan) pkgid of+    Just deps -> deps+    Nothing   -> internalError "revDirectDeps" "package not in graph"++-- | Return all the packages in the 'InstallPlan' in reverse topological order.+-- That is, for each package, all dependencies of the package appear first.+--+-- Compared to 'executionOrder', this function returns all the installed and+-- source packages rather than just the source ones. Also, while both this+-- and 'executionOrder' produce reverse topological orderings of the package+-- dependency graph, it is not necessarily exactly the same order.+--+reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg+                        -> [GenericPlanPackage ipkg srcpkg]+reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)+++-- | Return the packages in the plan that are direct or indirect dependencies of+-- the given packages.+--+dependencyClosure :: GenericInstallPlan ipkg srcpkg+                  -> [UnitId]+                  -> [GenericPlanPackage ipkg srcpkg]+dependencyClosure plan = fromMaybe []+                       . Graph.closure (planGraph plan)++-- | Return the packages in the plan that depend directly or indirectly on the+-- given packages.+--+reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg+                         -> [UnitId]+                         -> [GenericPlanPackage ipkg srcpkg]+reverseDependencyClosure plan = fromMaybe []+                              . Graph.revClosure (planGraph plan)+++-- Alert alert!   Why does SolverId map to a LIST of plan packages?+-- The sordid story has to do with 'build-depends' on a package+-- with libraries and executables.  In an ideal world, we would+-- ONLY depend on the library in this situation.  But c.f. #3661+-- some people rely on the build-depends to ALSO implicitly+-- depend on an executable.+--+-- I don't want to commit to a strategy yet, so the only possible+-- thing you can do in this case is return EVERYTHING and let+-- the client filter out what they want (executables? libraries?+-- etc).  This similarly implies we can't return a 'ConfiguredId'+-- because that's not enough information.++fromSolverInstallPlan ::+      (IsUnit ipkg, IsUnit srcpkg)+    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])+        -> SolverInstallPlan.SolverPlanPackage+        -> [GenericPlanPackage ipkg srcpkg]         )+    -> SolverInstallPlan+    -> GenericInstallPlan ipkg srcpkg+fromSolverInstallPlan f plan =+    mkInstallPlan "fromSolverInstallPlan"+      (Graph.fromDistinctList pkgs'')+      (SolverInstallPlan.planIndepGoals plan)+  where+    (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])+                        (SolverInstallPlan.reverseTopologicalOrder plan)++    f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)+      where+       pkgs' = f (mapDep pidMap ipiMap) pkg++       (pidMap', ipiMap')+         = case nodeKey pkg of+            PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)+            PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)++    mapDep _ ipiMap (PreExistingId _pid uid)+        | Just pkgs <- Map.lookup uid ipiMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)+    mapDep pidMap _ (PlannedId pid)+        | Just pkgs <- Map.lookup pid pidMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)+    -- This shouldn't happen, since mapDep should only be called+    -- on neighbor SolverId, which must have all been done already+    -- by the reverse top-sort (we assume the graph is not broken).+++fromSolverInstallPlanWithProgress ::+      (IsUnit ipkg, IsUnit srcpkg)+    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])+        -> SolverInstallPlan.SolverPlanPackage+        -> LogProgress [GenericPlanPackage ipkg srcpkg]         )+    -> SolverInstallPlan+    -> LogProgress (GenericInstallPlan ipkg srcpkg)+fromSolverInstallPlanWithProgress f plan = do+    (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])+                        (SolverInstallPlan.reverseTopologicalOrder plan)+    return $ mkInstallPlan "fromSolverInstallPlanWithProgress"+               (Graph.fromDistinctList pkgs'')+               (SolverInstallPlan.planIndepGoals plan)+  where+    f' (pidMap, ipiMap, pkgs) pkg = do+        pkgs' <- f (mapDep pidMap ipiMap) pkg+        let (pidMap', ipiMap')+                 = case nodeKey pkg of+                    PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)+                    PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)+        return (pidMap', ipiMap', pkgs' ++ pkgs)++    mapDep _ ipiMap (PreExistingId _pid uid)+        | Just pkgs <- Map.lookup uid ipiMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)+    mapDep pidMap _ (PlannedId pid)+        | Just pkgs <- Map.lookup pid pidMap = pkgs+        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)+    -- This shouldn't happen, since mapDep should only be called+    -- on neighbor SolverId, which must have all been done already+    -- by the reverse top-sort (we assume the graph is not broken).++-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.+-- Similar to 'elaboratedInstallPlan'+configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan+configureInstallPlan configFlags solverPlan =+    flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->+      [case planpkg of+        SolverInstallPlan.PreExisting pkg ->+          PreExisting (instSolverPkgIPI pkg)++        SolverInstallPlan.Configured  pkg ->+          Configured (configureSolverPackage mapDep pkg)+      ]+  where+    configureSolverPackage :: (SolverId -> [PlanPackage])+                           -> SolverPackage UnresolvedPkgLoc+                           -> ConfiguredPackage UnresolvedPkgLoc+    configureSolverPackage mapDep spkg =+      ConfiguredPackage {+        confPkgId = Configure.computeComponentId+                        (Cabal.fromFlagOrDefault False+                            (Cabal.configDeterministic configFlags))+                        Cabal.NoFlag+                        Cabal.NoFlag+                        (packageId spkg)+                        (PD.CLibName PD.LMainLibName)+                        (Just (map confInstId (CD.libraryDeps deps),+                               solverPkgFlags spkg)),+        confPkgSource = solverPkgSource spkg,+        confPkgFlags  = solverPkgFlags spkg,+        confPkgStanzas = solverPkgStanzas spkg,+        confPkgDeps   = deps+        -- NB: no support for executable dependencies+      }+      where+        deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg)+++-- ------------------------------------------------------------+-- * Primitives for traversing plans+-- ------------------------------------------------------------++-- $traversal+--+-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel,+-- may make use of the 'Processing' type and the associated operations+-- 'ready', 'completed' and 'failed'.+--+-- The 'Processing' type is used to keep track of the state of a traversal and+-- includes the set of packages that are in the processing state, e.g. in the+-- process of being installed, plus those that have been completed and those+-- where processing failed.+--+-- Traversal algorithms start with an 'InstallPlan':+--+-- * Initially there will be certain packages that can be processed immediately+--   (since they are configured source packages and have all their dependencies+--   installed already). The function 'ready' returns these packages plus a+--   'Processing' state that marks these same packages as being in the+--   processing state.+--+-- * The algorithm must now arrange for these packages to be processed+--   (possibly in parallel). When a package has completed processing, the+--   algorithm needs to know which other packages (if any) are now ready to+--   process as a result. The 'completed' function marks a package as completed+--   and returns any packages that are newly in the processing state (ie ready+--   to process), along with the updated 'Processing' state.+--+-- * If failure is possible then when processing a package fails, the algorithm+--   needs to know which other packages have also failed as a result. The+--   'failed' function marks the given package as failed as well as all the+--   other packages that depend on the failed package. In addition it returns+--   the other failed packages.+++-- | The 'Processing' type is used to keep track of the state of a traversal+-- and includes the set of packages that are in the processing state, e.g. in+-- the process of being installed, plus those that have been completed and+-- those where processing failed.+--+data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)+                            -- processing,   completed,    failed++-- | The packages in the plan that are initially ready to be installed.+-- That is they are in the configured state and have all their dependencies+-- installed already.+--+-- The result is both the packages that are now ready to be installed and also+-- a 'Processing' state containing those same packages. The assumption is that+-- all the packages that are ready will now be processed and so we can consider+-- them to be in the processing state.+--+ready :: (IsUnit ipkg, IsUnit srcpkg)+      => GenericInstallPlan ipkg srcpkg+      -> ([GenericReadyPackage srcpkg], Processing)+ready plan =+    assert (processingInvariant plan processing) $+    (readyPackages, processing)+  where+    !processing =+      Processing+        (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])+        (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])+        Set.empty+    readyPackages =+      [ ReadyPackage pkg+      | Configured pkg <- toList plan+      , all isInstalled (directDeps plan (nodeKey pkg))+      ]++isInstalled :: GenericPlanPackage a b -> Bool+isInstalled (PreExisting {}) = True+isInstalled (Installed   {}) = True+isInstalled _                = False++-- | Given a package in the processing state, mark the package as completed+-- and return any packages that are newly in the processing state (ie ready to+-- process), along with the updated 'Processing' state.+--+completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg)+          => GenericInstallPlan ipkg srcpkg+          -> Processing -> UnitId+          -> ([GenericReadyPackage srcpkg], Processing)+completed plan (Processing processingSet completedSet failedSet) pkgid =+    assert (pkgid `Set.member` processingSet) $+    assert (processingInvariant plan processing') $++    ( map asReadyPackage newlyReady+    , processing' )+  where+    completedSet'  = Set.insert pkgid completedSet++    -- each direct reverse dep where all direct deps are completed+    newlyReady     = [ dep+                     | dep <- revDirectDeps plan pkgid+                     , all ((`Set.member` completedSet') . nodeKey)+                           (directDeps plan (nodeKey dep))+                     ]++    processingSet' = foldl' (flip Set.insert)+                            (Set.delete pkgid processingSet)+                            (map nodeKey newlyReady)+    processing'    = Processing processingSet' completedSet' failedSet++    asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg+    asReadyPackage (Configured pkg)  = ReadyPackage pkg+    asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg++failed :: (IsUnit ipkg, IsUnit srcpkg)+       => GenericInstallPlan ipkg srcpkg+       -> Processing -> UnitId+       -> ([srcpkg], Processing)+failed plan (Processing processingSet completedSet failedSet) pkgid =+    assert (pkgid `Set.member` processingSet) $+    assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $+    assert (all (`Set.notMember` completedSet)  (tail newlyFailedIds)) $+    -- but note that some newlyFailed may already be in the failed set+    -- since one package can depend on two packages that both fail and+    -- so would be in the rev-dep closure for both.+    assert (processingInvariant plan processing') $++    ( map asConfiguredPackage (tail newlyFailed)+    , processing' )+  where+    processingSet' = Set.delete pkgid processingSet+    failedSet'     = failedSet `Set.union` Set.fromList newlyFailedIds+    newlyFailedIds = map nodeKey newlyFailed+    newlyFailed    = fromMaybe (internalError "failed" "package not in graph")+                   $ Graph.revClosure (planGraph plan) [pkgid]+    processing'    = Processing processingSet' completedSet failedSet'++    asConfiguredPackage (Configured pkg) = pkg+    asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg++processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)+                    => GenericInstallPlan ipkg srcpkg+                    -> Processing -> Bool+processingInvariant plan (Processing processingSet completedSet failedSet) =++    -- All the packages in the three sets are actually in the graph+    assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $+    assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $+    assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $++    -- The processing, completed and failed sets are disjoint from each other+    assert (noIntersection processingSet completedSet) $+    assert (noIntersection processingSet failedSet) $+    assert (noIntersection failedSet     completedSet) $++    -- Packages that depend on a package that's still processing cannot be+    -- completed+    assert (noIntersection (reverseClosure processingSet) completedSet) $++    -- On the other hand, packages that depend on a package that's still+    -- processing /can/ have failed (since they may have depended on multiple+    -- packages that were processing, but it only takes one to fail to cause+    -- knock-on failures) so it is quite possible to have an+    -- intersection (reverseClosure processingSet) failedSet++    -- The failed set is upwards closed, i.e. equal to its own rev dep closure+    assert (failedSet == reverseClosure failedSet) $++    -- All immediate reverse deps of packges that are currently processing+    -- are not currently being processed (ie not in the processing set).+    assert (and [ rdeppkgid `Set.notMember` processingSet+                | pkgid     <- Set.toList processingSet+                , rdeppkgid <- maybe (internalError "processingInvariant" "")+                                     (map nodeKey)+                                     (Graph.revNeighbors (planGraph plan) pkgid)+                ]) $++    -- Packages from the processing or failed sets are only ever in the+    -- configured state.+    assert (and [ case Graph.lookup pkgid (planGraph plan) of+                    Just (Configured  _) -> True+                    Just (PreExisting _) -> False+                    Just (Installed   _) -> False+                    Nothing              -> False+                | pkgid <- Set.toList processingSet ++ Set.toList failedSet ])++    -- We use asserts rather than returning False so that on failure we get+    -- better details on which bit of the invariant was violated.+    True+  where+    reverseClosure    = Set.fromList+                      . map nodeKey+                      . fromMaybe (internalError "processingInvariant" "")+                      . Graph.revClosure (planGraph plan)+                      . Set.toList+    noIntersection a b = Set.null (Set.intersection a b)+++-- ------------------------------------------------------------+-- * Traversing plans+-- ------------------------------------------------------------++-- | Flatten an 'InstallPlan', producing the sequence of source packages in+-- the order in which they would be processed when the plan is executed. This+-- can be used for simultations or presenting execution dry-runs.+--+-- It is guaranteed to give the same order as using 'execute' (with a serial+-- in-order 'JobControl'), which is a reverse topological orderings of the+-- source packages in the dependency graph, albeit not necessarily exactly the+-- same ordering as that produced by 'reverseTopologicalOrder'.+--+executionOrder :: (IsUnit ipkg, IsUnit srcpkg)+               => GenericInstallPlan ipkg srcpkg+               -> [GenericReadyPackage srcpkg]+executionOrder plan =+    let (newpkgs, processing) = ready plan+     in tryNewTasks processing newpkgs+  where+    tryNewTasks _processing []       = []+    tryNewTasks  processing (p:todo) = waitForTasks processing p todo++    waitForTasks processing p todo =+        p : tryNewTasks processing' (todo++nextpkgs)+      where+        (nextpkgs, processing') = completed plan processing (nodeKey p)+++-- ------------------------------------------------------------+-- * Executing plans+-- ------------------------------------------------------------++-- | The set of results we get from executing an install plan.+--+type BuildOutcomes failure result = Map UnitId (Either failure result)++-- | Lookup the build result for a single package.+--+lookupBuildOutcome :: HasUnitId pkg+                   => pkg -> BuildOutcomes failure result+                   -> Maybe (Either failure result)+lookupBuildOutcome = Map.lookup . installedUnitId++-- | Execute an install plan. This traverses the plan in dependency order.+--+-- Executing each individual package can fail and if so all dependents fail+-- too. The result for each package is collected as a 'BuildOutcomes' map.+--+-- Visiting each package happens with optional parallelism, as determined by+-- the 'JobControl'. By default, after any failure we stop as soon as possible+-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour+-- can be reversed to keep going and build as many packages as possible.+--+-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages+-- in the plan. In particular in the default mode where we stop as soon as+-- possible after a failure then there may be packages which are skipped and+-- these will have no 'BuildOutcome'.+--+execute :: forall m ipkg srcpkg result failure.+           (IsUnit ipkg, IsUnit srcpkg,+            Monad m)+        => JobControl m (UnitId, Either failure result)+        -> Bool                -- ^ Keep going after failure+        -> (srcpkg -> failure) -- ^ Value for dependents of failed packages+        -> GenericInstallPlan ipkg srcpkg+        -> (GenericReadyPackage srcpkg -> m (Either failure result))+        -> m (BuildOutcomes failure result)+execute jobCtl keepGoing depFailure plan installPkg =+    let (newpkgs, processing) = ready plan+     in tryNewTasks Map.empty False False processing newpkgs+  where+    tryNewTasks :: BuildOutcomes failure result+                -> Bool -> Bool -> Processing+                -> [GenericReadyPackage srcpkg]+                -> m (BuildOutcomes failure result)++    tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs+      -- we were in the process of cancelling and now we're finished+      | tasksFailed && not keepGoing && not tasksRemaining+      = return results++      -- we are still in the process of cancelling, wait for remaining tasks+      | tasksFailed && not keepGoing && tasksRemaining+      = waitForTasks results tasksFailed processing++      -- no new tasks to do and all tasks are done so we're finished+      | null newpkgs && not tasksRemaining+      = return results++      -- no new tasks to do, remaining tasks to wait for+      | null newpkgs+      = waitForTasks results tasksFailed processing++      -- new tasks to do, spawn them, then wait for tasks to complete+      | otherwise+      = do sequence_ [ spawnJob jobCtl $ do+                         result <- installPkg pkg+                         return (nodeKey pkg, result)+                     | pkg <- newpkgs ]+           waitForTasks results tasksFailed processing++    waitForTasks :: BuildOutcomes failure result+                 -> Bool -> Processing+                 -> m (BuildOutcomes failure result)+    waitForTasks !results tasksFailed !processing = do+      (pkgid, result) <- collectJob jobCtl++      case result of++        Right _success -> do+            tasksRemaining <- remainingJobs jobCtl+            tryNewTasks results' tasksFailed tasksRemaining+                        processing' nextpkgs+          where+            results' = Map.insert pkgid result results+            (nextpkgs, processing') = completed plan processing pkgid++        Left _failure -> do+            -- if this is the first failure and we're not trying to keep going+            -- then try to cancel as many of the remaining jobs as possible+            when (not tasksFailed && not keepGoing) $+              cancelJobs jobCtl++            tasksRemaining <- remainingJobs jobCtl+            tryNewTasks results' True tasksRemaining processing' []+          where+            (depsfailed, processing') = failed plan processing pkgid+            results'   = Map.insert pkgid result results `Map.union` depResults+            depResults = Map.fromList+                           [ (nodeKey deppkg, Left (depFailure deppkg))+                           | deppkg <- depsfailed ]++-- ------------------------------------------------------------+-- * Checking validity of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is closed, acyclic+-- and respects the package state relation.+--+-- * if the result is @False@ use 'problems' to get a detailed list.+--+valid :: (IsUnit ipkg, IsUnit srcpkg)+      => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool+valid loc graph =+    case problems graph of+      [] -> True+      ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))++data PlanProblem ipkg srcpkg =+     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg) [UnitId]+   | PackageCycle         [GenericPlanPackage ipkg srcpkg]+   | PackageStateInvalid  (GenericPlanPackage ipkg srcpkg)+                          (GenericPlanPackage ipkg srcpkg)++showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)+                => PlanProblem ipkg srcpkg -> String+showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ prettyShow (nodeKey pkg)+  ++ " depends on the following packages which are missing from the plan: "+  ++ intercalate ", " (map prettyShow missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)+showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ prettyShow (nodeKey pkg)+  ++ " is in the " ++ showPlanPackageTag pkg+  ++ " state but it depends on package " ++ prettyShow (nodeKey pkg')+  ++ " which is in the " ++ showPlanPackageTag pkg'+  ++ " state"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: (IsUnit ipkg, IsUnit srcpkg)+         => Graph (GenericPlanPackage ipkg srcpkg)+         -> [PlanProblem ipkg srcpkg]+problems graph =++     [ PackageMissingDeps pkg+       (mapMaybe+         (fmap nodeKey . flip Graph.lookup graph)+         missingDeps)+     | (pkg, missingDeps) <- Graph.broken graph ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- Graph.cycles graph ]+{-+  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <-+       dependencyInconsistencies indepGoals graph ]+     --TODO: consider re-enabling this one, see SolverInstallPlan+-}+  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- Foldable.toList graph+     , Just pkg' <- map (flip Graph.lookup graph)+                    (nodeNeighbors pkg)+     , not (stateDependencyRelation pkg pkg') ]++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @stateDependencyRelation a b = True@.+--+stateDependencyRelation :: GenericPlanPackage ipkg srcpkg+                        -> GenericPlanPackage ipkg srcpkg -> Bool+stateDependencyRelation PreExisting{} PreExisting{} = True++stateDependencyRelation Installed{}   PreExisting{} = True+stateDependencyRelation Installed{}   Installed{}   = True++stateDependencyRelation Configured{}  PreExisting{} = True+stateDependencyRelation Configured{}  Installed{}   = True+stateDependencyRelation Configured{}  Configured{}  = True++stateDependencyRelation _             _             = False
+ src/Distribution/Client/InstallSymlink.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallSymlink+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Managing installing binaries with symlinks.+-----------------------------------------------------------------------------+module Distribution.Client.InstallSymlink (+    symlinkBinaries,+    symlinkBinary,+    trySymlink,+  ) where++import Distribution.Client.Compat.Prelude hiding (ioError)+import Prelude ()++import Distribution.Client.Types+         ( ConfiguredPackage(..), BuildOutcomes )+import Distribution.Client.Setup+         ( InstallFlags(installSymlinkBinDir) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)++import Distribution.Solver.Types.SourcePackage+import Distribution.Solver.Types.OptionalStanza++import Distribution.Package+         ( PackageIdentifier, Package(packageId), UnitId, installedUnitId )+import Distribution.Types.UnqualComponentName+import Distribution.Compiler+         ( CompilerId(..) )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePD )+import Distribution.Simple.Setup+         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.InstallDirs as InstallDirs+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo, CompilerInfo(..) )+import Distribution.System+         ( Platform )+import Distribution.Simple.Utils ( info, withTempDirectory )++import System.Directory+         ( canonicalizePath, getTemporaryDirectory, removeFile )+import System.FilePath+         ( (</>), splitPath, joinPath, isAbsolute )++import System.IO.Error+         ( isDoesNotExistError, ioError )+import Control.Exception+         ( assert )++import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )+import Distribution.Client.Types.OverwritePolicy++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8++-- | We would like by default to install binaries into some location that is on+-- the user's PATH. For per-user installations on Unix systems that basically+-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@+-- 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 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+-- 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+-- with symlinks so is not available to Windows users.+--+symlinkBinaries :: Platform -> Compiler+                -> OverwritePolicy+                -> ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> BuildOutcomes+                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]+symlinkBinaries platform comp overwritePolicy+                configFlags installFlags+                plan buildOutcomes =+  case flagToMaybe (installSymlinkBinDir installFlags) of+    Nothing            -> return []+    Just symlinkBinDir+           | null exes -> return []+           | otherwise -> do+      publicBinDir  <- canonicalizePath symlinkBinDir+--    TODO: do we want to do this here? :+--      createDirectoryIfMissing True publicBinDir+      fmap catMaybes $ sequenceA+        [ do privateBinDir <- pkgBinDir pkg ipid+             ok <- symlinkBinary+                     overwritePolicy+                     publicBinDir  privateBinDir+                     (prettyShow publicExeName) privateExeName+             if ok+               then return Nothing+               else return (Just (pkgid, publicExeName,+                                  privateBinDir </> privateExeName))+        | (rpkg, pkg, exe) <- exes+        , let pkgid  = packageId pkg+              -- This is a bit dodgy; probably won't work for Backpack packages+              ipid = installedUnitId rpkg+              publicExeName  = PackageDescription.exeName exe+              privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix+              prefix = substTemplate pkgid ipid prefixTemplate+              suffix = substTemplate pkgid ipid suffixTemplate ]+  where+    exes =+      [ (cpkg, pkg, exe)+      | InstallPlan.Configured cpkg <- InstallPlan.toList plan+      , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of+          Just (Right _success) -> True+          _                     -> False+      , let pkg :: PackageDescription+            pkg = pkgDescription cpkg+      , exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]++    pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _)+                                      flags stanzas _) =+      case finalizePD flags (enableStanzas stanzas)+             (const True)+             platform cinfo [] gpd of+        Left _ -> error "finalizePD ReadyPackage failed"+        Right (desc, _) -> desc++    -- This is sadly rather complicated. We're kind of re-doing part of the+    -- configuration for the package. :-(+    pkgBinDir :: PackageDescription -> UnitId -> IO FilePath+    pkgBinDir pkg ipid = do+      defaultDirs <- InstallDirs.defaultInstallDirs+                       compilerFlavor+                       (fromFlag (configUserInstall configFlags))+                       (PackageDescription.hasLibs pkg)+      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+          absoluteDirs = InstallDirs.absoluteInstallDirs+                           (packageId pkg) ipid+                           cinfo InstallDirs.NoCopyDest+                           platform templateDirs+      canonicalizePath (InstallDirs.bindir absoluteDirs)++    substTemplate pkgid ipid = InstallDirs.fromPathTemplate+                             . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid ipid+                                                     cinfo platform++    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)+    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)+    cinfo            = compilerInfo comp+    (CompilerId compilerFlavor _) = compilerInfoId cinfo++-- | Symlink binary.+--+-- The paths are take in pieces, so we can make relative link when possible.+--+symlinkBinary ::+  OverwritePolicy        -- ^ Whether to force overwrite an existing file+  -> FilePath            -- ^ The canonical path of the public bin dir eg+                         --   @/home/user/bin@+  -> FilePath            -- ^ The canonical path of the private bin dir eg+                         --   @/home/user/.cabal/bin@+  -> FilePath            -- ^ The name of the executable to go in the public bin+                         --   dir, eg @foo@+  -> String              -- ^ The name of the executable to in the private bin+                         --   dir, eg @foo-1.0@+  -> 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.+symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do+  ok <- targetOkToOverwrite (publicBindir </> publicName)+                            (privateBindir </> privateName)+  case ok of+    NotExists         ->           mkLink >> return True+    OkToOverwrite     -> rmLink >> mkLink >> return True+    NotOurFile ->+      case overwritePolicy of+        NeverOverwrite  ->                     return False+        AlwaysOverwrite -> rmLink >> mkLink >> return True+  where+    relativeBindir = makeRelative publicBindir privateBindir+    mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)+    rmLink = removeFile (publicBindir </> publicName)++-- | Check a file path of a symlink that we would like to create to see if it+-- is OK. For it to be OK to overwrite it must either not already exist yet or+-- be a symlink to our target (in which case we can assume ownership).+--+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.+                    -> IO SymlinkStatus+targetOkToOverwrite symlink target = handleNotExist $ do+  isLink <- pathIsSymbolicLink symlink+  if not isLink+    then return NotOurFile+    else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink+            -- This partially relies on canonicalizePath handling symlinks+            if target == target'+              then return OkToOverwrite+              else return NotOurFile++  where+    handleNotExist action = catchIO action $ \ioexception ->+      -- If the target doesn't exist then there's no problem overwriting it!+      if isDoesNotExistError ioexception+        then return NotExists+        else ioError ioexception++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 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).+  deriving Show++-- | Take two canonical paths and produce a relative path to get from the first+-- to the second, even if it means adding @..@ path components.+--+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative a b = assert (isAbsolute a && isAbsolute b) $+  let as = splitPath a+      bs = splitPath b+      commonLen = length $ takeWhile id $ zipWith (==) as bs+   in joinPath $ [ ".." | _  <- drop commonLen as ]+              ++ drop commonLen bs++-- | Try to make a symlink in a temporary directory.+--+-- If this works, we can try to symlink: even on Windows.+--+trySymlink :: Verbosity -> IO Bool+trySymlink verbosity = do+  tmp <- getTemporaryDirectory+  withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do+    let from = tmpDirPath </> "file.txt"+    let to   = tmpDirPath </> "file2.txt"++    -- create a file+    BS.writeFile from (BS8.pack "TEST")++    -- create a symbolic link+    let create :: IO Bool+        create = do+          createFileLink from to+          info verbosity $ "Symlinking seems to work"+          return True++    create `catchIO` \exc -> do+      info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc+      return False
+ src/Distribution/Client/JobControl.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.JobControl+-- Copyright   :  (c) Duncan Coutts 2012+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A job control concurrency abstraction+-----------------------------------------------------------------------------+module Distribution.Client.JobControl (+    JobControl,+    newSerialJobControl,+    newParallelJobControl,+    spawnJob,+    collectJob,+    remainingJobs,+    cancelJobs,++    JobLimit,+    newJobLimit,+    withJobLimit,++    Lock,+    newLock,+    criticalSection+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Control.Monad (forever, replicateM_)+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Control.Concurrent.STM (STM, atomically)+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan+import Control.Exception (bracket_, try)+import Distribution.Compat.Stack+import Distribution.Client.Compat.Semaphore+++-- | A simple concurrency abstraction. Jobs can be spawned and can complete+-- in any order. This allows both serial and parallel implementations.+--+data JobControl m a = JobControl {+       -- | Add a new job to the pool of jobs+       spawnJob    :: m a -> m (),++       -- | Wait until one job is complete+       collectJob  :: m a,++       -- | Returns True if there are any outstanding jobs+       -- (ie spawned but yet to be collected)+       remainingJobs :: m Bool,++       -- | Try to cancel any outstanding but not-yet-started jobs.+       -- Call 'remainingJobs' after this to find out if any jobs are left+       -- (ie could not be cancelled).+       cancelJobs  :: m ()+     }+++-- | Make a 'JobControl' that executes all jobs serially and in order.+-- It only executes jobs on demand when they are collected, not eagerly.+--+-- Cancelling will cancel /all/ jobs that have not been collected yet.+--+newSerialJobControl :: IO (JobControl IO a)+newSerialJobControl = do+    qVar <- newTChanIO+    return JobControl {+      spawnJob      = spawn     qVar,+      collectJob    = collect   qVar,+      remainingJobs = remaining qVar,+      cancelJobs    = cancel    qVar+    }+  where+    spawn :: TChan (IO a) -> IO a -> IO ()+    spawn qVar job = atomically $ writeTChan qVar job++    collect :: TChan (IO a) -> IO a+    collect qVar =+      join $ atomically $ readTChan qVar++    remaining :: TChan (IO a) -> IO Bool+    remaining qVar  = fmap not $ atomically $ isEmptyTChan qVar++    cancel :: TChan (IO a) -> IO ()+    cancel qVar = do+      _ <- atomically $ readAllTChan qVar+      return ()++-- | Make a 'JobControl' that eagerly executes jobs in parallel, with a given+-- maximum degree of parallelism.+--+-- Cancelling will cancel jobs that have not yet begun executing, but jobs+-- that have already been executed or are currently executing cannot be+-- cancelled.+--+newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a))+newParallelJobControl n | n < 1 || n > 1000 =+  error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n+newParallelJobControl maxJobLimit = do+    inqVar   <- newTChanIO+    outqVar  <- newTChanIO+    countVar <- newTVarIO 0+    replicateM_ maxJobLimit $+      forkIO $+        worker inqVar outqVar+    return JobControl {+      spawnJob      = spawn   inqVar  countVar,+      collectJob    = collect outqVar countVar,+      remainingJobs = remaining       countVar,+      cancelJobs    = cancel  inqVar  countVar+    }+  where+    worker ::  TChan (IO a) -> TChan (Either SomeException a) -> IO ()+    worker inqVar outqVar =+      forever $ do+        job <- atomically $ readTChan inqVar+        res <- try job+        atomically $ writeTChan outqVar res++    spawn :: TChan (IO a) -> TVar Int -> IO a -> IO ()+    spawn inqVar countVar job =+      atomically $ do+        modifyTVar' countVar (+1)+        writeTChan inqVar job++    collect :: TChan (Either SomeException a) -> TVar Int -> IO a+    collect outqVar countVar = do+      res <- atomically $ do+        modifyTVar' countVar (subtract 1)+        readTChan outqVar+      either throwIO return res++    remaining :: TVar Int -> IO Bool+    remaining countVar = fmap (/=0) $ atomically $ readTVar countVar++    cancel :: TChan (IO a) -> TVar Int -> IO ()+    cancel inqVar countVar =+      atomically $ do+        xs <- readAllTChan inqVar+        modifyTVar' countVar (subtract (length xs))++readAllTChan :: TChan a -> STM [a]+readAllTChan qvar = go []+  where+    go xs = do+      mx <- tryReadTChan qvar+      case mx of+        Nothing -> return (reverse xs)+        Just x  -> go (x:xs)++-------------------------+-- Job limits and locks+--++data JobLimit = JobLimit QSem++newJobLimit :: Int -> IO JobLimit+newJobLimit n =+  fmap JobLimit (newQSem n)++withJobLimit :: JobLimit -> IO a -> IO a+withJobLimit (JobLimit sem) =+  bracket_ (waitQSem sem) (signalQSem sem)++newtype Lock = Lock (MVar ())++newLock :: IO Lock+newLock = fmap Lock $ newMVar ()++criticalSection :: Lock -> IO a -> IO a+criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
+ src/Distribution/Client/List.hs view
@@ -0,0 +1,628 @@+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.List+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2008-2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+--+-- Search for and print information about packages+-----------------------------------------------------------------------------+module Distribution.Client.List (+  list, info+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Package+         ( PackageName, Package(..), packageName+         , packageVersion, UnitId )+import Distribution.Types.Dependency+import Distribution.Types.UnqualComponentName+import Distribution.ModuleName (ModuleName)+import Distribution.License (License)+import qualified Distribution.InstalledPackageInfo as Installed+import qualified Distribution.PackageDescription   as Source+import Distribution.PackageDescription+         ( PackageFlag(..), unFlagName )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )++import Distribution.Simple.Compiler+        ( Compiler, PackageDBStack )+import Distribution.Simple.Program (ProgramDb)+import Distribution.Simple.Utils+        ( equating, die', notice )+import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault)+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+import Distribution.Version+         ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion+         , intersectVersionRanges, simplifyVersionRange )++import qualified Distribution.SPDX as SPDX++import           Distribution.Solver.Types.PackageConstraint+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage++import Distribution.Client.Types+         ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage )+import Distribution.Client.Targets+         ( UserTarget, resolveUserTargets )+import Distribution.Client.Setup+         ( GlobalFlags(..), ListFlags(..), InfoFlags(..)+         , RepoContext(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.FetchUtils+         ( isFetched )++import Data.Bits ((.|.))+import Data.List+         ( maximumBy )+import Data.List.NonEmpty (groupBy)+import qualified Data.List as L+import Data.Maybe+         ( fromJust )+import qualified Data.Map as Map+import Data.Tree as Tree+import Control.Exception+         ( assert )+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( lineLength, ribbonsPerLine, Doc, renderStyle, char+         , nest, ($+$), text, vcat, style, parens, fsep)+import System.Directory+         ( doesDirectoryExist )++import Distribution.Utils.ShortText (ShortText)+import qualified Distribution.Utils.ShortText as ShortText+import qualified Text.Regex.Base as Regex+import qualified Text.Regex.Posix.String as Regex+++-- | Return a list of packages matching given search strings.+getPkgList :: Verbosity+           -> PackageDBStack+           -> RepoContext+           -> Maybe (Compiler, ProgramDb)+           -> ListFlags+           -> [String]+           -> IO [PackageDisplayInfo]+getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do+    installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->+        getInstalledPackages verbosity comp packageDBs progdb+    sourcePkgDb       <- getSourcePackages verbosity repoCtxt++    regexps <- for pats $ \pat -> do+        e <- Regex.compile compOption Regex.execBlank pat+        case e of+            Right r  -> return r+            Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err++    let sourcePkgIndex = packageIndex sourcePkgDb+        prefs name = fromMaybe anyVersion+                       (Map.lookup name (packagePreferences sourcePkgDb))++        pkgsInfoMatching ::+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]+        pkgsInfoMatching =+          let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex+              matchingSource    = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex+          in mergePackages matchingInstalled matchingSource++        pkgsInfo ::+          [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]+        pkgsInfo+            -- gather info for all packages+          | null regexps = mergePackages+                           (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)+                           (         PackageIndex.allPackages          sourcePkgIndex)++            -- gather info for packages matching search term+          | otherwise = pkgsInfoMatching++        matches :: [PackageDisplayInfo]+        matches = [ mergePackageInfo pref+                      installedPkgs sourcePkgs selectedPkg False+                  | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo+                  , not onlyInstalled || not (null installedPkgs)+                  , let pref        = prefs pkgname+                        selectedPkg = latestWithPref pref sourcePkgs ]+    return matches+  where+    onlyInstalled   = fromFlagOrDefault False (listInstalled listFlags)+    caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags)++    compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase+               | otherwise       = Regex.compExtended++    matchingPackages search regexps index =+      [ pkg+      | re <- regexps+      , pkg <- search index (Regex.matchTest re) ]+++-- | Show information about packages.+list :: Verbosity+     -> PackageDBStack+     -> RepoContext+     -> Maybe (Compiler, ProgramDb)+     -> ListFlags+     -> [String]+     -> IO ()+list verbosity packageDBs repos mcompProgdb listFlags pats = do+    matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats++    if simpleOutput+      then putStr $ unlines+             [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version+             | pkg <- matches+             , version <- if onlyInstalled+                            then              installedVersions pkg+                            else nub . sort $ installedVersions pkg+                                           ++ sourceVersions    pkg ]+             -- Note: this only works because for 'list', one cannot currently+             -- specify any version constraints, so listing all installed+             -- and source ones works.+      else+        if null matches+            then notice verbosity "No matches found."+            else putStr $ unlines (map showPackageSummaryInfo matches)+  where+    onlyInstalled = fromFlag (listInstalled listFlags)+    simpleOutput  = fromFlag (listSimpleOutput listFlags)++info :: Verbosity+     -> PackageDBStack+     -> RepoContext+     -> Compiler+     -> ProgramDb+     -> GlobalFlags+     -> InfoFlags+     -> [UserTarget]+     -> IO ()+info verbosity _ _ _ _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++info verbosity packageDBs repoCtxt comp progdb+     globalFlags _listFlags userTargets = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb+    sourcePkgDb       <- getSourcePackages verbosity repoCtxt+    let sourcePkgIndex = packageIndex sourcePkgDb+        prefs name = fromMaybe anyVersion+                       (Map.lookup name (packagePreferences sourcePkgDb))++        -- Users may specify names of packages that are only installed, not+        -- just available source packages, so we must resolve targets using+        -- the combination of installed and source packages.+    let sourcePkgs' = PackageIndex.fromList+                    $ map packageId+                      (InstalledPackageIndex.allPackages installedPkgIndex)+                   ++ map packageId+                      (PackageIndex.allPackages sourcePkgIndex)+    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt+                       (fromFlag $ globalWorldFile globalFlags)+                       sourcePkgs' userTargets++    pkgsinfo      <- sequenceA+                       [ do pkginfo <- either (die' verbosity) return $+                                         gatherPkgInfo prefs+                                           installedPkgIndex sourcePkgIndex+                                           pkgSpecifier+                            updateFileSystemPackageDetails pkginfo+                       | pkgSpecifier <- pkgSpecifiers ]++    putStr $ unlines (map showPackageDetailedInfo pkgsinfo)++  where+    gatherPkgInfo :: (PackageName -> VersionRange) ->+                     InstalledPackageIndex ->+                     PackageIndex.PackageIndex UnresolvedSourcePackage ->+                     PackageSpecifier UnresolvedSourcePackage ->+                     Either String PackageDisplayInfo+    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex+      (NamedPackage name props)+      | null (selectedInstalledPkgs) && null (selectedSourcePkgs)+      = Left $ "There is no available version of " ++ prettyShow name+            ++ " that satisfies "+            ++ prettyShow (simplifyVersionRange verConstraint)++      | otherwise+      = Right $ mergePackageInfo pref installedPkgs+                                 sourcePkgs  selectedSourcePkg'+                                 showPkgVersion+      where+        (pref, installedPkgs, sourcePkgs) =+          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex++        selectedInstalledPkgs = InstalledPackageIndex.lookupDependency+                                installedPkgIndex+                                name verConstraint+        selectedSourcePkgs    = PackageIndex.lookupDependency sourcePkgIndex+                                name verConstraint+        selectedSourcePkg'    = latestWithPref pref selectedSourcePkgs++                         -- display a specific package version if the user+                         -- supplied a non-trivial version constraint+        showPkgVersion = not (null verConstraints)+        verConstraint  = foldr intersectVersionRanges anyVersion verConstraints+        verConstraints = [ vr | PackagePropertyVersion vr <- props ]++    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex+      (SpecificSourcePackage pkg) =+        Right $ mergePackageInfo pref installedPkgs sourcePkgs+                                 selectedPkg True+      where+        name          = packageName pkg+        selectedPkg   = Just pkg+        (pref, installedPkgs, sourcePkgs) =+          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex++sourcePkgsInfo ::+  (PackageName -> VersionRange)+  -> PackageName+  -> InstalledPackageIndex+  -> PackageIndex.PackageIndex UnresolvedSourcePackage+  -> (VersionRange, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])+sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =+  (pref, installedPkgs, sourcePkgs)+  where+    pref          = prefs name+    installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName+                                   installedPkgIndex name)+    sourcePkgs    = PackageIndex.lookupPackageName sourcePkgIndex name+++-- | The info that we can display for each package. It is information per+-- package name and covers all installed and available versions.+--+data PackageDisplayInfo = PackageDisplayInfo {+    pkgName           :: PackageName,+    selectedVersion   :: Maybe Version,+    selectedSourcePkg :: Maybe UnresolvedSourcePackage,+    installedVersions :: [Version],+    sourceVersions    :: [Version],+    preferredVersions :: VersionRange,+    homepage          :: ShortText,+    bugReports        :: ShortText,+    sourceRepo        :: String, -- TODO+    synopsis          :: ShortText,+    description       :: ShortText,+    category          :: ShortText,+    license           :: Either SPDX.License License,+    author            :: ShortText,+    maintainer        :: ShortText,+    dependencies      :: [ExtDependency],+    flags             :: [PackageFlag],+    hasLib            :: Bool,+    hasExe            :: Bool,+    executables       :: [UnqualComponentName],+    modules           :: [ModuleName],+    haddockHtml       :: FilePath,+    haveTarball       :: Bool+  }++-- | Covers source dependencies and installed dependencies in+-- one type.+data ExtDependency = SourceDependency Dependency+                   | InstalledDependency UnitId++showPackageSummaryInfo :: PackageDisplayInfo -> String+showPackageSummaryInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+     char '*' <+> pretty (pkgName pkginfo)+     $+$+     (nest 4 $ vcat [+       maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs+     , text "Default available version:" <+>+       case selectedSourcePkg pkginfo of+         Nothing  -> text "[ Not available from any configured repository ]"+         Just pkg -> pretty (packageVersion pkg)+     , text "Installed versions:" <+>+       case installedVersions pkginfo of+         []  | hasLib pkginfo -> text "[ Not installed ]"+             | otherwise      -> text "[ Unknown ]"+         versions             -> dispTopVersions 4+                                   (preferredVersions pkginfo) versions+     , maybeShowST (homepage pkginfo) "Homepage:" text+     , text "License: " <+> either pretty pretty (license pkginfo)+     ])+     $+$ text ""+  where+    maybeShowST l s f+        | ShortText.null l = Disp.empty+        | otherwise        = text s <+> f (ShortText.fromShortText l)++showPackageDetailedInfo :: PackageDisplayInfo -> String+showPackageDetailedInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+   char '*' <+> pretty (pkgName pkginfo)+            <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)+            <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')+            <<>> parens pkgkind+   $+$+   (nest 4 $ vcat [+     entryST "Synopsis"      synopsis     hideIfNull  reflowParagraphs+   , entry "Versions available" sourceVersions+           (altText null "[ Not available from server ]")+           (dispTopVersions 9 (preferredVersions pkginfo))+   , entry "Versions installed" installedVersions+           (altText null (if hasLib pkginfo then "[ Not installed ]"+                                            else "[ Unknown ]"))+           (dispTopVersions 4 (preferredVersions pkginfo))+   , entryST "Homepage"      homepage     orNotSpecified text+   , entryST "Bug reports"   bugReports   orNotSpecified text+   , entryST "Description"   description  hideIfNull     reflowParagraphs+   , entryST "Category"      category     hideIfNull     text+   , entry "License"       license      alwaysShow     (either pretty pretty)+   , entryST "Author"        author       hideIfNull     reflowLines+   , entryST "Maintainer"    maintainer   hideIfNull     reflowLines+   , entry "Source repo"   sourceRepo   orNotSpecified text+   , entry "Executables"   executables  hideIfNull     (commaSep pretty)+   , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)+   , entry "Dependencies"  dependencies hideIfNull     (commaSep dispExtDep)+   , entry "Documentation" haddockHtml  showIfInstalled text+   , entry "Cached"        haveTarball  alwaysShow     dispYesNo+   , if not (hasLib pkginfo) then mempty else+     text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))+   ])+   $+$ text ""+  where+    entry fname field cond format = case cond (field pkginfo) of+      Nothing           -> label <+> format (field pkginfo)+      Just Nothing      -> mempty+      Just (Just other) -> label <+> text other+      where+        label   = text fname Disp.<> char ':' Disp.<> padding+        padding = text (replicate (13 - length fname ) ' ')++    entryST fname field = entry fname (ShortText.fromShortText . field)++    normal      = Nothing+    hide        = Just Nothing+    replace msg = Just (Just msg)++    alwaysShow = const normal+    hideIfNull v = if null v then hide else normal+    showIfInstalled v+      | not isInstalled = hide+      | null v          = replace "[ Not installed ]"+      | otherwise       = normal+    altText nul msg v = if nul v then replace msg else normal+    orNotSpecified = altText null "[ Not specified ]"++    commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f+    dispFlag = text . unFlagName . flagName+    dispYesNo True  = text "Yes"+    dispYesNo False = text "No"++    dispExtDep (SourceDependency    dep) = pretty dep+    dispExtDep (InstalledDependency dep) = pretty dep++    isInstalled = not (null (installedVersions pkginfo))+    hasExes = length (executables pkginfo) >= 2+    --TODO: exclude non-buildable exes+    pkgkind | hasLib pkginfo && hasExes        = text "programs and library"+            | hasLib pkginfo && hasExe pkginfo = text "program and library"+            | hasLib pkginfo                   = text "library"+            | hasExes                          = text "programs"+            | hasExe pkginfo                   = text "program"+            | otherwise                        = mempty+++reflowParagraphs :: String -> Doc+reflowParagraphs =+    vcat+  . intersperse (text "")                    -- re-insert blank lines+  . map (fsep . map text . concatMap words)  -- reflow paragraphs+  . filter (/= [""])+  . L.groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines+  . lines++reflowLines :: String -> Doc+reflowLines = vcat . map text . lines++-- | We get the 'PackageDisplayInfo' by combining the info for the installed+-- and available versions of a package.+--+-- * We're building info about a various versions of a single named package so+-- the input package info records are all supposed to refer to the same+-- package name.+--+mergePackageInfo :: VersionRange+                 -> [Installed.InstalledPackageInfo]+                 -> [UnresolvedSourcePackage]+                 -> Maybe UnresolvedSourcePackage+                 -> Bool+                 -> PackageDisplayInfo+mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =+  assert (length installedPkgs + length sourcePkgs > 0) $+  PackageDisplayInfo {+    pkgName           = combine packageName source+                                packageName installed,+    selectedVersion   = if showVer then fmap packageVersion selectedPkg+                                   else Nothing,+    selectedSourcePkg = sourceSelected,+    installedVersions = map packageVersion installedPkgs,+    sourceVersions    = map packageVersion sourcePkgs,+    preferredVersions = versionPref,++    license      = combine Source.licenseRaw    source+                           Installed.license    installed,+    maintainer   = combine Source.maintainer    source+                           Installed.maintainer installed,+    author       = combine Source.author        source+                           Installed.author     installed,+    homepage     = combine Source.homepage      source+                           Installed.homepage   installed,+    bugReports   = maybe mempty Source.bugReports source,+    sourceRepo   = fromMaybe mempty . join+                 . fmap (uncons Nothing Source.repoLocation+                       . sortBy (comparing Source.repoKind)+                       . Source.sourceRepos)+                 $ source,+                    --TODO: installed package info is missing synopsis+    synopsis     = maybe mempty Source.synopsis      source,+    description  = combine Source.description    source+                           Installed.description installed,+    category     = combine Source.category       source+                           Installed.category    installed,+    flags        = maybe [] Source.genPackageFlags sourceGeneric,+    hasLib       = isJust installed+                || maybe False (isJust . Source.condLibrary) sourceGeneric,+    hasExe       = maybe False (not . null . Source.condExecutables) sourceGeneric,+    executables  = map fst (maybe [] Source.condExecutables sourceGeneric),+    modules      = combine (map Installed.exposedName . Installed.exposedModules)+                           installed+                           -- NB: only for the PUBLIC library+                           (concatMap getListOfExposedModules . maybeToList . Source.library)+                           source,+    dependencies =+      combine (map (SourceDependency . simplifyDependency)+               . Source.allBuildDepends) source+      (map InstalledDependency . Installed.depends) installed,+    haddockHtml  = fromMaybe "" . join+                 . fmap (listToMaybe . Installed.haddockHTMLs)+                 $ installed,+    haveTarball  = False+  }+  where+    combine f x g y  = fromJust (fmap f x `mplus` fmap g y)+    installed :: Maybe Installed.InstalledPackageInfo+    installed = latestWithPref versionPref installedPkgs++    getListOfExposedModules lib = Source.exposedModules lib+                               ++ map Source.moduleReexportName+                                      (Source.reexportedModules lib)++    sourceSelected+      | isJust selectedPkg = selectedPkg+      | otherwise          = latestWithPref versionPref sourcePkgs+    sourceGeneric = fmap srcpkgDescription sourceSelected+    source        = fmap flattenPackageDescription sourceGeneric++    uncons :: b -> (a -> b) -> [a] -> b+    uncons z _ []    = z+    uncons _ f (x:_) = f x+++-- | Not all the info is pure. We have to check if the docs really are+-- installed, because the registered package info lies. Similarly we have to+-- check if the tarball has indeed been fetched.+--+updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo+updateFileSystemPackageDetails pkginfo = do+  fetched   <- maybe (return False) (isFetched . srcpkgSource)+                     (selectedSourcePkg pkginfo)+  docsExist <- doesDirectoryExist (haddockHtml pkginfo)+  return pkginfo {+    haveTarball = fetched,+    haddockHtml = if docsExist then haddockHtml pkginfo else ""+  }++latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg+latestWithPref _    []   = Nothing+latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)+  where+    prefThenVersion pkg = let ver = packageVersion pkg+                           in (withinRange ver pref, ver)+++-- | Rearrange installed and source packages into groups referring to the+-- same package by name. In the result pairs, the lists are guaranteed to not+-- both be empty.+--+mergePackages :: [Installed.InstalledPackageInfo]+              -> [UnresolvedSourcePackage]+              -> [( PackageName+                  , [Installed.InstalledPackageInfo]+                  , [UnresolvedSourcePackage] )]+mergePackages installedPkgs sourcePkgs =+    map collect+  $ mergeBy (\i a -> fst i `compare` fst a)+            (groupOn packageName installedPkgs)+            (groupOn packageName sourcePkgs)+  where+    collect (OnlyInLeft  (name,is)         ) = (name, is, [])+    collect (    InBoth  (_,is)   (name,as)) = (name, is, as)+    collect (OnlyInRight          (name,as)) = (name, [], as)++groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]+groupOn key = map (\xs -> (key (head xs), toList xs))+            . groupBy (equating key)+            . sortBy (comparing key)++dispTopVersions :: Int -> VersionRange -> [Version] -> Doc+dispTopVersions n pref vs =+         (Disp.fsep . Disp.punctuate (Disp.char ',')+        . map (\ver -> if ispref ver then pretty ver else parens (pretty ver))+        . sort . take n . interestingVersions ispref+        $ vs)+    <+> trailingMessage++  where+    ispref ver = withinRange ver pref+    extra = length vs - n+    trailingMessage+      | extra <= 0 = Disp.empty+      | otherwise  = Disp.parens $ Disp.text "and"+                               <+> Disp.int (length vs - n)+                               <+> if extra == 1 then Disp.text "other"+                                                 else Disp.text "others"++-- | Reorder a bunch of versions to put the most interesting / significant+-- versions first. A preferred version range is taken into account.+--+-- This may be used in a user interface to select a small number of versions+-- to present to the user, e.g.+--+-- > let selectVersions = sort . take 5 . interestingVersions pref+--+interestingVersions :: (Version -> Bool) -> [Version] -> [Version]+interestingVersions pref =+      map (mkVersion . fst) . filter snd+    . concat  . Tree.levels+    . swizzleTree+    . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))+    . reverseTree+    . mkTree+    . map (or0 . versionNumbers)++  where+    or0 []     = 0 :| []+    or0 (x:xs) = x :| xs++    swizzleTree = unfoldTree (spine [])+      where+        spine ts' (Node x [])     = (x, ts')+        spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t++    reorderTree _ (Node x []) = Node x []+    reorderTree p (Node x ts) = Node x (ts' ++ ts'')+      where+        (ts',ts'') = partition p (map (reorderTree p) ts)++    reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))++    mkTree :: forall a. Eq a => [NonEmpty a] -> Tree ([a], Bool)+    mkTree xs = unfoldTree step (False, [], xs)+      where+        step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])+        step (node,ns,vs) =+          ( (reverse ns, node)+          , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs'))+            | (n, vs') <- groups vs+            ]+          )++        groups :: [NonEmpty a] -> [(a, NonEmpty [a])]+        groups = map (\g -> (head (head g), fmap tail g))+               . groupBy (equating head)
+ src/Distribution/Client/Manpage.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Manpage+-- Copyright   :  (c) Maciek Makowski 2015+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for building the manual page.++module Distribution.Client.Manpage+  ( -- * Manual page generation+    manpage+  , manpageCmd+  , ManpageFlags+  , defaultManpageFlags+  , manpageOptions+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ManpageFlags+import Distribution.Client.Setup        (globalCommand)+import Distribution.Compat.Process      (createProcess)+import Distribution.Simple.Command+import Distribution.Simple.Flag         (fromFlagOrDefault)+import System.IO                        (hClose, hPutStr)++import qualified System.Process as Process++data FileInfo = FileInfo String String -- ^ path, description++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++-- | A list of files that should be documented in the manual page.+files :: [FileInfo]+files =+  [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.")+  , (FileInfo "~/.cabal/world"  "A list of all packages whose installation has been explicitly requested.")+  ]++manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()+manpageCmd pname commands flags+    | fromFlagOrDefault False (manpageRaw flags)+    = putStrLn contents+    | otherwise+    = do+        let cmd  = "man"+            args = ["-l", "-"]++        (mb_in, _, _, ph) <- createProcess (Process.proc cmd args)+            { Process.std_in  = Process.CreatePipe+            , Process.std_out = Process.Inherit+            , Process.std_err = Process.Inherit+            }++        -- put contents+        for_ mb_in $ \hin -> do+            hPutStr hin contents+            hClose hin++        -- wait for process to exit, propagate exit code+        ec <- Process.waitForProcess ph+        exitWith ec+  where+    contents :: String+    contents = manpage pname commands++-- | Produces a manual page with @troff@ markup.+manpage :: String -> [CommandSpec a] -> String+manpage pname commands = unlines $+  [ ".TH " ++ map toUpper pname ++ " 1"+  , ".SH NAME"+  , pname ++ " \\- a system for building and packaging Haskell libraries and programs"+  , ".SH SYNOPSIS"+  , ".B " ++ pname+  , ".I command"+  , ".RI < arguments |[ options ]>..."+  , ""+  , "Where the"+  , ".I commands"+  , "are"+  , ""+  ] +++  concatMap (commandSynopsisLines pname) commands +++  [ ".SH DESCRIPTION"+  , "Cabal is the standard package system for Haskell software. It helps people to configure, "+  , "build and install Haskell software and to distribute it easily to other users and developers."+  , ""+  , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "+  , "installing existing packages and developing new packages. "+  , "It can be used to work with local packages or to install packages from online package archives, "+  , "including automatically installing dependencies. By default it is configured to use Hackage, "+  , "which is Haskell's central package archive that contains thousands of libraries and applications "+  , "in the Cabal package format."+  , ".SH OPTIONS"+  , "Global options:"+  , ""+  ] +++  optionsLines (globalCommand []) +++  [ ".SH COMMANDS"+  ] +++  concatMap (commandDetailsLines pname) commands +++  [ ".SH FILES"+  ] +++  concatMap fileLines files +++  [ ".SH BUGS"+  , "To browse the list of known issues or report a new one please see "+  , "https://github.com/haskell/cabal/labels/cabal-install."+  ]++commandSynopsisLines :: String -> CommandSpec action -> [String]+commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =+  [ ".B " ++ pname ++ " " ++ (commandName ui)+  , ".R - " ++ commandSynopsis ui+  , ".br"+  ]+commandSynopsisLines _ (CommandSpec _ _ HiddenCommand) = []++commandDetailsLines :: String -> CommandSpec action -> [String]+commandDetailsLines pname (CommandSpec ui _ NormalCommand) =+  [ ".B " ++ pname ++ " " ++ (commandName ui)+  , ""+  , commandUsage ui pname+  , ""+  ] +++  optional commandDescription +++  optional commandNotes +++  [ "Flags:"+  , ".RS"+  ] +++  optionsLines ui +++  [ ".RE"+  , ""+  ]+  where+    optional field =+      case field ui of+        Just text -> [text pname, ""]+        Nothing   -> []+commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []++optionsLines :: CommandUI flags -> [String]+optionsLines command = concatMap optionLines (concatMap optionDescr (commandOptions command ParseArgs))++data ArgumentRequired = Optional | Required+type OptionArg = (ArgumentRequired, ArgPlaceHolder)++optionLines :: OptDescr flags -> [String]+optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =+  argOptionLines description optionChars optionStrings (Required, placeHolder)+optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =+  argOptionLines description optionChars optionStrings (Optional, placeHolder)+optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =+  optionLinesIfPresent trueChars trueStrings +++  optionLinesIfPresent falseChars falseStrings +++  optionDescriptionLines description+optionLines (ChoiceOpt options) =+  concatMap choiceLines options+  where+    choiceLines (description, (optionChars, optionStrings), _, _) =+      [ optionsLine optionChars optionStrings ] +++      optionDescriptionLines description++argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]+argOptionLines description optionChars optionStrings arg =+  [ optionsLine optionChars optionStrings+  , optionArgLine arg+  ] +++  optionDescriptionLines description++optionLinesIfPresent :: [Char] -> [String] -> [String]+optionLinesIfPresent optionChars optionStrings =+  if null optionChars && null optionStrings then []+  else                                           [ optionsLine optionChars optionStrings, ".br" ]++optionDescriptionLines :: String -> [String]+optionDescriptionLines description =+  [ ".RS"+  , description+  , ".RE"+  , ""+  ]++optionsLine :: [Char] -> [String] -> String+optionsLine optionChars optionStrings =+  intercalate ", " (shortOptions optionChars ++ longOptions optionStrings)++shortOptions :: [Char] -> [String]+shortOptions = map (\c -> "\\-" ++ [c])++longOptions :: [String] -> [String]+longOptions = map (\s -> "\\-\\-" ++ s)++optionArgLine :: OptionArg -> String+optionArgLine (Required, placeHolder) = ".I " ++ placeHolder+optionArgLine (Optional, placeHolder) = ".RI [ " ++ placeHolder ++ " ]"++fileLines :: FileInfo -> [String]+fileLines (FileInfo path description) =+  [ path+  , ".RS"+  , description+  , ".RE"+  , ""+  ]
+ src/Distribution/Client/ManpageFlags.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase    #-}+module Distribution.Client.ManpageFlags+( ManpageFlags (..)+, defaultManpageFlags+, manpageOptions,+) where++import Distribution.Client.Compat.Prelude++import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)+import Distribution.Simple.Setup   (Flag (..), toFlag, trueArg, optionVerbosity)+import Distribution.Verbosity      (normal)++data ManpageFlags = ManpageFlags+  { manpageVerbosity :: Flag Verbosity+  , manpageRaw       :: Flag Bool+  } deriving (Eq, Show, Generic)++instance Monoid ManpageFlags  where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ManpageFlags where+  (<>) = gmappend++defaultManpageFlags :: ManpageFlags+defaultManpageFlags = ManpageFlags+    { manpageVerbosity = toFlag normal+    , manpageRaw       = toFlag False+    }++manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags]+manpageOptions _ =+    [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v })+    , option "" ["raw"]+      "Output raw troff content"+      manpageRaw (\v flags -> flags { manpageRaw = v })+      trueArg+    ]
+ src/Distribution/Client/Nix.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++module Distribution.Client.Nix+       ( findNixExpr+       , inNixShell+       , nixInstantiate+       , nixShell+       ) where++import Distribution.Client.Compat.Prelude++import Control.Exception (bracket)+import System.Directory+       ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist+       , doesFileExist, removeDirectoryRecursive, removeFile )+import System.Environment (getArgs, getExecutablePath)+import System.FilePath+       ( (</>), replaceExtension, takeDirectory, takeFileName )+import System.IO (IOMode(..), hClose, openFile)+import System.IO.Error (isDoesNotExistError)+import System.Process (showCommandForUser)++import Distribution.Compat.Environment+       ( lookupEnv, setEnv, unsetEnv )++import Distribution.Simple.Program+       ( Program(..), ProgramDb+       , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput+       , runDbProgram, simpleProgram )+import Distribution.Simple.Setup (fromFlagOrDefault)+import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan)++import Distribution.Client.Config (SavedConfig(..))+import Distribution.Client.GlobalFlags (GlobalFlags(..))+++configureOneProgram :: Verbosity -> Program -> IO ProgramDb+configureOneProgram verb prog =+  configureProgram verb prog (addKnownProgram prog emptyProgramDb)+++touchFile :: FilePath -> IO ()+touchFile path = do+  catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ()))+  createDirectoryIfMissing True (takeDirectory path)+  openFile path WriteMode >>= hClose+++findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath)+findNixExpr globalFlags config = do+  -- criteria for deciding to run nix-shell+  let nixEnabled =+        fromFlagOrDefault False+        (globalNix (savedGlobalFlags config) <> globalNix globalFlags)++  if nixEnabled+    then do+      let exprPaths = [ "shell.nix", "default.nix" ]+      filterM doesFileExist exprPaths >>= \case+        [] -> return Nothing+        (path : _) -> return (Just path)+    else return Nothing+++-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell+inFakeNixShell :: IO a -> IO a+inFakeNixShell f =+  bracket (fakeEnv "IN_NIX_SHELL" "1") (resetEnv "IN_NIX_SHELL") (\_ -> f)+  where+    fakeEnv var new = do+      old <- lookupEnv var+      setEnv var new+      return old+    resetEnv var = maybe (unsetEnv var) (setEnv var)+++nixInstantiate+  :: Verbosity+  -> FilePath+  -> Bool+  -> GlobalFlags+  -> SavedConfig+  -> IO ()+nixInstantiate verb dist force' globalFlags config =+  findNixExpr globalFlags config >>= \case+    Nothing -> return ()+    Just shellNix -> do+      alreadyInShell <- inNixShell+      shellDrv <- drvPath dist shellNix+      instantiated <- doesFileExist shellDrv+      -- an extra timestamp file is necessary because the derivation lives in+      -- the store so its mtime is always 1.+      let timestamp = timestampPath dist shellNix+      upToDate <- existsAndIsMoreRecentThan timestamp shellNix++      let ready = alreadyInShell || (instantiated && upToDate && not force')+      unless ready $ do++        let prog = simpleProgram "nix-instantiate"+        progdb <- configureOneProgram verb prog++        removeGCRoots verb dist+        touchFile timestamp++        _ <- inFakeNixShell+             (getDbProgramOutput verb prog progdb+              [ "--add-root", shellDrv, "--indirect", shellNix ])+        return ()+++nixShell+  :: Verbosity+  -> FilePath+  -> GlobalFlags+  -> SavedConfig+  -> IO ()+     -- ^ The action to perform inside a nix-shell. This is also the action+     -- that will be performed immediately if Nix is disabled.+  -> IO ()+nixShell verb dist globalFlags config go = do++  alreadyInShell <- inNixShell++  if alreadyInShell+    then go+    else do+      findNixExpr globalFlags config >>= \case+        Nothing -> go+        Just shellNix -> do++          let prog = simpleProgram "nix-shell"+          progdb <- configureOneProgram verb prog++          cabal <- getExecutablePath++          -- alreadyInShell == True in child process+          setEnv "CABAL_IN_NIX_SHELL" "1"++          -- Run cabal with the same arguments inside nix-shell.+          -- When the child process reaches the top of nixShell, it will+          -- detect that it is running inside the shell and fall back+          -- automatically.+          shellDrv <- drvPath dist shellNix+          args <- getArgs+          runDbProgram verb prog progdb+            [ "--add-root", gcrootPath dist </> "result", "--indirect", shellDrv+            , "--run", showCommandForUser cabal args+            ]+++drvPath :: FilePath -> FilePath -> IO FilePath+drvPath dist path = do+  -- We do not actually care about canonicity, but makeAbsolute is only+  -- available in newer versions of directory.+  -- We expect the path to be a symlink if it exists, so we do not canonicalize+  -- the entire path because that would dereference the symlink.+  distNix <- canonicalizePath (dist </> "nix")+  -- Nix garbage collector roots must be absolute paths+  return (distNix </> replaceExtension (takeFileName path) "drv")+++timestampPath :: FilePath -> FilePath -> FilePath+timestampPath dist path =+  dist </> "nix" </> replaceExtension (takeFileName path) "drv.timestamp"+++gcrootPath :: FilePath -> FilePath+gcrootPath dist = dist </> "nix" </> "gcroots"+++inNixShell :: IO Bool+inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL"+++removeGCRoots :: Verbosity -> FilePath -> IO ()+removeGCRoots verb dist = do+  let tgt = gcrootPath dist+  exists <- doesDirectoryExist tgt+  when exists $ do+    debug verb ("removing Nix gcroots from " ++ tgt)+    removeDirectoryRecursive tgt
+ src/Distribution/Client/NixStyleOptions.hs view
@@ -0,0 +1,85 @@+-- | Command line options for nix-style / v2 commands.+--+-- The commands take a lot of the same options, which affect how install plan+-- is constructed.+module Distribution.Client.NixStyleOptions (+    NixStyleFlags (..),+    nixStyleOptions,+    defaultNixStyleFlags,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Simple.Command                       (OptionField (..), ShowOrParseArgs)+import Distribution.Simple.Setup                         (BenchmarkFlags, HaddockFlags, TestFlags)+import Distribution.Solver.Types.ConstraintSource        (ConstraintSource (..))++import Distribution.Client.ProjectFlags+       (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions)+import Distribution.Client.Setup+       (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions,+       configureOptions, haddockOptions, installOptions, liftOptions, testOptions)++data NixStyleFlags a = NixStyleFlags+    { configFlags    :: ConfigFlags+    , configExFlags  :: ConfigExFlags+    , installFlags   :: InstallFlags+    , haddockFlags   :: HaddockFlags+    , testFlags      :: TestFlags+    , benchmarkFlags :: BenchmarkFlags+    , projectFlags   :: ProjectFlags+    , extraFlags     :: a+    }++nixStyleOptions+    :: (ShowOrParseArgs -> [OptionField a])+    -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]+nixStyleOptions commandOptions showOrParseArgs =+        liftOptions configFlags     set1+        -- Note: [Hidden Flags]+        -- hide "constraint", "dependency", and+        -- "exact-configuration" from the configure options.+        (filter ((`notElem` ["constraint", "dependency"+                            , "exact-configuration"])+                 . optionName) $ configureOptions showOrParseArgs)+     ++ liftOptions configExFlags   set2 (configureExOptions showOrParseArgs+                               ConstraintSourceCommandlineFlag)+     ++ liftOptions installFlags   set3+        -- hide "target-package-db" and "symlink-bindir" flags from the+        -- install options.+        -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags+        (filter ((`notElem` ["target-package-db", "symlink-bindir"])+                 . optionName) $+                               installOptions showOrParseArgs)+       ++ liftOptions haddockFlags set4+          -- hide "verbose" and "builddir" flags from the+          -- haddock options.+          (filter ((`notElem` ["v", "verbose", "builddir"])+                  . optionName) $+                                haddockOptions showOrParseArgs)+     ++ liftOptions testFlags      set5 (testOptions showOrParseArgs)+     ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs)+     ++ liftOptions projectFlags   set7 (projectFlagsOptions showOrParseArgs)+     ++ liftOptions extraFlags     set8 (commandOptions showOrParseArgs)+  where+    set1 x flags = flags { configFlags    = x }+    set2 x flags = flags { configExFlags  = x }+    set3 x flags = flags { installFlags   = x }+    set4 x flags = flags { haddockFlags   = x }+    set5 x flags = flags { testFlags      = x }+    set6 x flags = flags { benchmarkFlags = x }+    set7 x flags = flags { projectFlags   = x }+    set8 x flags = flags { extraFlags     = x }++defaultNixStyleFlags :: a ->  NixStyleFlags a+defaultNixStyleFlags x = NixStyleFlags+    { configFlags    = mempty+    , configExFlags  = mempty+    , installFlags   = mempty+    , haddockFlags   = mempty+    , testFlags      = mempty+    , benchmarkFlags = mempty+    , projectFlags   = defaultProjectFlags+    , extraFlags     = x+    }
+ src/Distribution/Client/Outdated.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Outdated+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'outdated' command. Checks for outdated+-- dependencies in the package description file or freeze file.+-----------------------------------------------------------------------------++module Distribution.Client.Outdated ( outdated+                                    , ListOutdatedSettings(..), listOutdated )+where++import Prelude ()+import Distribution.Client.Config+import Distribution.Client.IndexUtils as IndexUtils+import Distribution.Client.Compat.Prelude+import Distribution.Client.ProjectConfig+import Distribution.Client.DistDirLayout+import Distribution.Client.RebuildMonad+import Distribution.Client.Setup hiding (quiet)+import Distribution.Client.Targets+import Distribution.Client.Types+import Distribution.Solver.Types.PackageConstraint+import Distribution.Solver.Types.PackageIndex+import Distribution.Client.Sandbox.PackageEnvironment+import Distribution.Utils.Generic++import Distribution.Package                          (PackageName, packageVersion)+import Distribution.PackageDescription               (allBuildDepends)+import Distribution.PackageDescription.Configuration (finalizePD)+import Distribution.Simple.Compiler                  (Compiler, compilerInfo)+import Distribution.Simple.Setup+       (fromFlagOrDefault, flagToMaybe)+import Distribution.Simple.Utils+       (die', notice, debug, tryFindPackageDesc)+import Distribution.System                           (Platform)+import Distribution.Types.ComponentRequestedSpec+       (ComponentRequestedSpec(..))+import Distribution.Types.Dependency+       (Dependency(..))+import Distribution.Verbosity                        (silent)+import Distribution.Version+       (Version, VersionInterval (..), VersionRange, LowerBound(..), UpperBound(..)+       ,asVersionIntervals, majorBoundVersion)+import Distribution.PackageDescription.Parsec+       (readGenericPackageDescription)+import Distribution.Types.PackageVersionConstraint+       (PackageVersionConstraint (..), simplifyPackageVersionConstraint)++import qualified Data.Set as S+import System.Directory                              (getCurrentDirectory)++-- | Entry point for the 'outdated' command.+outdated :: Verbosity -> OutdatedFlags -> RepoContext+         -> Compiler -> Platform+         -> IO ()+outdated verbosity0 outdatedFlags repoContext comp platform = do+  let freezeFile    = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags)+      newFreezeFile = fromFlagOrDefault False+                      (outdatedNewFreezeFile outdatedFlags)+      mprojectFile  = flagToMaybe+                      (outdatedProjectFile outdatedFlags)+      simpleOutput  = fromFlagOrDefault False+                      (outdatedSimpleOutput outdatedFlags)+      quiet         = fromFlagOrDefault False (outdatedQuiet outdatedFlags)+      exitCode      = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags)+      ignorePred    = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags)+                      in \pkgname -> pkgname `S.member` ignoreSet+      minorPred     = case outdatedMinor outdatedFlags of+                        Nothing -> const False+                        Just IgnoreMajorVersionBumpsNone -> const False+                        Just IgnoreMajorVersionBumpsAll  -> const True+                        Just (IgnoreMajorVersionBumpsSome pkgs) ->+                          let minorSet = S.fromList pkgs+                          in \pkgname -> pkgname `S.member` minorSet+      verbosity     = if quiet then silent else verbosity0++  when (not newFreezeFile && isJust mprojectFile) $+    die' verbosity $+      "--project-file must only be used with --v2-freeze-file."++  sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext+  let pkgIndex = packageIndex sourcePkgDb+  deps <- if freezeFile+          then depsFromFreezeFile verbosity+          else if newFreezeFile+               then depsFromNewFreezeFile verbosity mprojectFile+               else depsFromPkgDesc verbosity comp platform+  debug verbosity $ "Dependencies loaded: "+    ++ (intercalate ", " $ map prettyShow deps)+  let outdatedDeps = listOutdated deps pkgIndex+                     (ListOutdatedSettings ignorePred minorPred)+  when (not quiet) $+    showResult verbosity outdatedDeps simpleOutput+  if (exitCode && (not . null $ outdatedDeps))+    then exitFailure+    else return ()++-- | Print either the list of all outdated dependencies, or a message+-- that there are none.+showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO ()+showResult verbosity outdatedDeps simpleOutput =+  if (not . null $ outdatedDeps)+    then+    do when (not simpleOutput) $+         notice verbosity "Outdated dependencies:"+       for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->+         let outdatedDep = if simpleOutput then prettyShow pn+                           else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"+         in notice verbosity outdatedDep+    else notice verbosity "All dependencies are up to date."++-- | Convert a list of 'UserConstraint's to a 'Dependency' list.+userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint]+userConstraintsToDependencies ucnstrs =+  mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs++-- | Read the list of dependencies from the freeze file.+depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]+depsFromFreezeFile verbosity = do+  cwd        <- getCurrentDirectory+  userConfig <- loadUserConfig verbosity cwd Nothing+  let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $+                userConfig+      deps    = userConstraintsToDependencies ucnstrs+  debug verbosity "Reading the list of dependencies from the freeze file"+  return deps++-- | Read the list of dependencies from the new-style freeze file.+depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [PackageVersionConstraint]+depsFromNewFreezeFile verbosity mprojectFile = do+  projectRoot <- either throwIO return =<<+                 findProjectRoot Nothing mprojectFile+  let distDirLayout = defaultDistDirLayout projectRoot+                      {- TODO: Support dist dir override -} Nothing+  projectConfig  <- runRebuild (distProjectRootDirectory distDirLayout) $+                    readProjectLocalFreezeConfig verbosity distDirLayout+  let ucnstrs = map fst . projectConfigConstraints . projectConfigShared+                $ projectConfig+      deps    = userConstraintsToDependencies ucnstrs+  debug verbosity $+    "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze"+  return deps++-- | Read the list of dependencies from the package description.+depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [PackageVersionConstraint]+depsFromPkgDesc verbosity comp platform = do+  cwd  <- getCurrentDirectory+  path <- tryFindPackageDesc verbosity cwd+  gpd  <- readGenericPackageDescription verbosity path+  let cinfo = compilerInfo comp+      epd = finalizePD mempty (ComponentRequestedSpec True True)+            (const True) platform cinfo [] gpd+  case epd of+    Left _        -> die' verbosity "finalizePD failed"+    Right (pd, _) -> do+      let bd = allBuildDepends pd+      debug verbosity+        "Reading the list of dependencies from the package description"+      return $ map toPVC bd+  where+    toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr++-- | Various knobs for customising the behaviour of 'listOutdated'.+data ListOutdatedSettings = ListOutdatedSettings {+  -- | Should this package be ignored?+  listOutdatedIgnorePred :: PackageName -> Bool,+  -- | Should major version bumps should be ignored for this package?+  listOutdatedMinorPred  :: PackageName -> Bool+  }++-- | Find all outdated dependencies.+listOutdated :: [PackageVersionConstraint]+             -> PackageIndex UnresolvedSourcePackage+             -> ListOutdatedSettings+             -> [(PackageVersionConstraint, Version)]+listOutdated deps pkgIndex (ListOutdatedSettings ignorePred minorPred) =+  mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps+  where+    isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)+    isOutdated dep@(PackageVersionConstraint pname vr)+      | ignorePred pname = Nothing+      | otherwise                   =+          let this   = map packageVersion $ lookupDependency pkgIndex pname vr+              latest = lookupLatest dep+          in (\v -> (dep, v)) `fmap` isOutdated' this latest++    isOutdated' :: [Version] -> [Version] -> Maybe Version+    isOutdated' [] _  = Nothing+    isOutdated' _  [] = Nothing+    isOutdated' this latest =+      let this'   = maximum this+          latest' = maximum latest+      in if this' < latest' then Just latest' else Nothing++    lookupLatest :: PackageVersionConstraint -> [Version]+    lookupLatest (PackageVersionConstraint pname vr)+      | minorPred pname =+        map packageVersion $ lookupDependency pkgIndex  pname (relaxMinor vr)+      | otherwise =+        map packageVersion $ lookupPackageName pkgIndex pname++    relaxMinor :: VersionRange -> VersionRange+    relaxMinor vr =+      let vis = asVersionIntervals vr+      in maybe vr relax (safeLast vis)+      where relax (VersionInterval (LowerBound v0 _) upper) =+              case upper of+                NoUpperBound     -> vr+                UpperBound _v1 _ -> majorBoundVersion v0
+ src/Distribution/Client/PackageHash.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}++-- | Functions to calculate nix-style hashes for package ids.+--+-- The basic idea is simple, hash the combination of:+--+--   * the package tarball+--   * the ids of all the direct dependencies+--   * other local configuration (flags, profiling, etc)+--+module Distribution.Client.PackageHash (+    -- * Calculating package hashes+    PackageHashInputs(..),+    PackageHashConfigInputs(..),+    PackageSourceHash,+    hashedInstalledPackageId,+    hashPackageHashInputs,+    renderPackageHashInputs,+    -- ** Platform-specific variations+    hashedInstalledPackageIdLong,+    hashedInstalledPackageIdShort,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Package+         ( PackageId, PackageIdentifier(..), mkComponentId+         , PkgconfigName )+import Distribution.System+         ( Platform, OS(Windows, OSX), buildOS )+import Distribution.Types.Flag+         ( FlagAssignment, showFlagAssignment )+import Distribution.Simple.Compiler+         ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)+         , ProfDetailLevel(..), showProfDetailLevel )+import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate )+import Distribution.Types.PkgconfigVersion (PkgconfigVersion)+import Distribution.Client.HashValue+import Distribution.Client.Types+         ( InstalledPackageId )+import qualified Distribution.Solver.Types.ComponentDeps as CD++import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Map as Map+import qualified Data.Set as Set++-------------------------------+-- Calculating package hashes+--++-- | Calculate a 'InstalledPackageId' for a package using our nix-style+-- inputs hashing method.+--+-- Note that due to path length limitations on Windows, this function uses+-- a different method on Windows that produces shorted package ids.+-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'.+--+hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageId+  | buildOS == Windows = hashedInstalledPackageIdShort+  | buildOS == OSX     = hashedInstalledPackageIdVeryShort+  | otherwise          = hashedInstalledPackageIdLong++-- | Calculate a 'InstalledPackageId' for a package using our nix-style+-- inputs hashing method.+--+-- This produces large ids with big hashes. It is only suitable for systems+-- without significant path length limitations (ie not Windows).+--+hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageIdLong+    pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent}+    = mkComponentId $+           prettyShow pkgHashPkgId   -- to be a bit user friendly+        ++ maybe "" displayComponent pkgHashComponent+        ++ "-"+        ++ showHashValue (hashPackageHashInputs pkghashinputs)+  where+    displayComponent :: CD.Component -> String+    displayComponent CD.ComponentLib        = ""+    displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s+    displayComponent (CD.ComponentFLib s)   = "-f-" ++ prettyShow s+    displayComponent (CD.ComponentExe s)    = "-e-" ++ prettyShow s+    displayComponent (CD.ComponentTest s)   = "-t-" ++ prettyShow s+    displayComponent (CD.ComponentBench s)  = "-b-" ++ prettyShow s+    displayComponent CD.ComponentSetup      = "-setup"++-- | On Windows we have serious problems with path lengths. Windows imposes a+-- maximum path length of 260 chars, and even if we can use the windows long+-- path APIs ourselves, we cannot guarantee that ghc, gcc, ld, ar, etc etc all+-- do so too.+--+-- So our only choice is to limit the lengths of the paths, and the only real+-- way to do that is to limit the size of the 'InstalledPackageId's that we+-- generate. We do this by truncating the package names and versions and also+-- by truncating the hash sizes.+--+-- Truncating the package names and versions is technically ok because they are+-- just included for human convenience, the full source package id is included+-- in the hash.+--+-- Truncating the hash size is disappointing but also technically ok. We+-- rely on the hash primarily for collision avoidance not for any security+-- properties (at least for now).+--+hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =+    mkComponentId $+      intercalate "-"+        -- max length now 64+        [ truncateStr 14 (prettyShow name)+        , truncateStr  8 (prettyShow version)+        , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))+        ]+  where+    PackageIdentifier name version = pkgHashPkgId++    -- Truncate a string, with a visual indication that it is truncated.+    truncateStr n s | length s <= n = s+                    | otherwise     = take (n-1) s ++ "_"++-- | On macOS we shorten the name very aggressively.  The mach-o linker on+-- macOS has a limited load command size, to which the name of the library+-- as well as its relative path (\@rpath) entry count.  To circumvent this,+-- on macOS the libraries are not stored as+--  @store/<libraryname>/libHS<libraryname>.dylib@+-- where libraryname contains the libraries name, version and abi hash, but in+--  @store/lib/libHS<very short libraryname>.dylib@+-- where the very short library name drops all vowels from the package name,+-- and truncates the hash to 4 bytes.+--+-- We therefore we only need one \@rpath entry to @store/lib@ instead of one+-- \@rpath entry for each library. And the reduced library name saves some+-- additional space.+--+-- This however has two major drawbacks:+-- 1) Packages can collide more easily due to the shortened hash.+-- 2) The libraries are *not* prefix relocatable anymore as they all end up+--    in the same @store/lib@ folder.+--+-- The ultimate solution would have to include generating proxy dynamic+-- libraries on macOS, such that the proxy libraries and the linked libraries+-- stay under the load command limit, and the recursive linker is still able+-- to link all of them.+hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId+hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =+  mkComponentId $+    intercalate "-"+      [ filter (not . flip elem "aeiou") (prettyShow name)+      , prettyShow version+      , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs))+      ]+  where+    PackageIdentifier name version = pkgHashPkgId++-- | All the information that contribues to a package's hash, and thus its+-- 'InstalledPackageId'.+--+data PackageHashInputs = PackageHashInputs {+       pkgHashPkgId         :: PackageId,+       pkgHashComponent     :: Maybe CD.Component,+       pkgHashSourceHash    :: PackageSourceHash,+       pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion),+       pkgHashDirectDeps    :: Set InstalledPackageId,+       pkgHashOtherConfig   :: PackageHashConfigInputs+     }++type PackageSourceHash = HashValue++-- | Those parts of the package configuration that contribute to the+-- package hash.+--+data PackageHashConfigInputs = PackageHashConfigInputs {+       pkgHashCompilerId          :: CompilerId,+       pkgHashPlatform            :: Platform,+       pkgHashFlagAssignment      :: FlagAssignment, -- complete not partial+       pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure+       pkgHashVanillaLib          :: Bool,+       pkgHashSharedLib           :: Bool,+       pkgHashDynExe              :: Bool,+       pkgHashFullyStaticExe      :: Bool,+       pkgHashGHCiLib             :: Bool,+       pkgHashProfLib             :: Bool,+       pkgHashProfExe             :: Bool,+       pkgHashProfLibDetail       :: ProfDetailLevel,+       pkgHashProfExeDetail       :: ProfDetailLevel,+       pkgHashCoverage            :: Bool,+       pkgHashOptimization        :: OptimisationLevel,+       pkgHashSplitObjs           :: Bool,+       pkgHashSplitSections       :: Bool,+       pkgHashStripLibs           :: Bool,+       pkgHashStripExes           :: Bool,+       pkgHashDebugInfo           :: DebugInfoLevel,+       pkgHashProgramArgs         :: Map String [String],+       pkgHashExtraLibDirs        :: [FilePath],+       pkgHashExtraFrameworkDirs  :: [FilePath],+       pkgHashExtraIncludeDirs    :: [FilePath],+       pkgHashProgPrefix          :: Maybe PathTemplate,+       pkgHashProgSuffix          :: Maybe PathTemplate,++       -- Haddock options+       pkgHashDocumentation       :: Bool,+       pkgHashHaddockHoogle       :: Bool,+       pkgHashHaddockHtml         :: Bool,+       pkgHashHaddockHtmlLocation :: Maybe String,+       pkgHashHaddockForeignLibs  :: Bool,+       pkgHashHaddockExecutables  :: Bool,+       pkgHashHaddockTestSuites   :: Bool,+       pkgHashHaddockBenchmarks   :: Bool,+       pkgHashHaddockInternal     :: Bool,+       pkgHashHaddockCss          :: Maybe FilePath,+       pkgHashHaddockLinkedSource :: Bool,+       pkgHashHaddockQuickJump    :: Bool,+       pkgHashHaddockContents     :: Maybe PathTemplate++--     TODO: [required eventually] pkgHashToolsVersions     ?+--     TODO: [required eventually] pkgHashToolsExtraOptions ?+     }+  deriving Show+++-- | Calculate the overall hash to be used for an 'InstalledPackageId'.+--+hashPackageHashInputs :: PackageHashInputs -> HashValue+hashPackageHashInputs = hashValue . renderPackageHashInputs++-- | Render a textual representation of the 'PackageHashInputs'.+--+-- The 'hashValue' of this text is the overall package hash.+--+renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString+renderPackageHashInputs PackageHashInputs{+                          pkgHashPkgId,+                          pkgHashComponent,+                          pkgHashSourceHash,+                          pkgHashDirectDeps,+                          pkgHashPkgConfigDeps,+                          pkgHashOtherConfig =+                            PackageHashConfigInputs{..}+                        } =+    -- The purpose of this somewhat laboured rendering (e.g. why not just+    -- use show?) is so that existing package hashes do not change+    -- unnecessarily when new configuration inputs are added into the hash.++    -- In particular, the assumption is that when a new configuration input+    -- is included into the hash, that existing packages will typically get+    -- the default value for that feature. So if we avoid adding entries with+    -- the default value then most of the time adding new features will not+    -- change the hashes of existing packages and so fewer packages will need+    -- to be rebuilt.++    --TODO: [nice to have] ultimately we probably want to put this config info+    -- into the ghc-pkg db. At that point this should probably be changed to+    -- use the config file infrastructure so it can be read back in again.+    LBS.pack $ unlines $ catMaybes $+      [ entry "pkgid"       prettyShow pkgHashPkgId+      , mentry "component"  show pkgHashComponent+      , entry "src"         showHashValue pkgHashSourceHash+      , entry "pkg-config-deps"+                            (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn +++                                                    case mb_v of+                                                        Nothing -> ""+                                                        Just v -> " " ++ prettyShow v)+                                              . Set.toList) pkgHashPkgConfigDeps+      , entry "deps"        (intercalate ", " . map prettyShow+                                              . Set.toList) pkgHashDirectDeps+        -- and then all the config+      , entry "compilerid"  prettyShow pkgHashCompilerId+      , entry "platform" prettyShow pkgHashPlatform+      , opt   "flags" mempty showFlagAssignment pkgHashFlagAssignment+      , opt   "configure-script" [] unwords pkgHashConfigureScriptArgs+      , opt   "vanilla-lib" True  prettyShow pkgHashVanillaLib+      , opt   "shared-lib"  False prettyShow pkgHashSharedLib+      , opt   "dynamic-exe" False prettyShow pkgHashDynExe+      , opt   "fully-static-exe" False prettyShow pkgHashFullyStaticExe+      , opt   "ghci-lib"    False prettyShow pkgHashGHCiLib+      , opt   "prof-lib"    False prettyShow pkgHashProfLib+      , opt   "prof-exe"    False prettyShow pkgHashProfExe+      , opt   "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail+      , opt   "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail+      , opt   "hpc"          False prettyShow pkgHashCoverage+      , opt   "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization+      , opt   "split-objs"   False prettyShow pkgHashSplitObjs+      , opt   "split-sections" False prettyShow pkgHashSplitSections+      , opt   "stripped-lib" False prettyShow pkgHashStripLibs+      , opt   "stripped-exe" True  prettyShow pkgHashStripExes+      , opt   "debug-info"   NormalDebugInfo (show . fromEnum) pkgHashDebugInfo+      , opt   "extra-lib-dirs"     [] unwords pkgHashExtraLibDirs+      , opt   "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs+      , opt   "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs+      , opt   "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix+      , opt   "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix++      , opt   "documentation"  False prettyShow pkgHashDocumentation+      , opt   "haddock-hoogle" False prettyShow pkgHashHaddockHoogle+      , opt   "haddock-html"   False prettyShow pkgHashHaddockHtml+      , opt   "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation+      , opt   "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs+      , opt   "haddock-executables" False prettyShow pkgHashHaddockExecutables+      , opt   "haddock-tests" False prettyShow pkgHashHaddockTestSuites+      , opt   "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks+      , opt   "haddock-internal" False prettyShow pkgHashHaddockInternal+      , opt   "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss+      , opt   "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource+      , opt   "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump+      , opt   "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents++      ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs+  where+    entry key     format value = Just (key ++ ": " ++ format value)+    mentry key    format value = fmap (\v -> key ++ ": " ++ format v) value+    opt   key def format value+         | value == def = Nothing+         | otherwise    = entry key format value
+ src/Distribution/Client/ParseUtils.hs view
@@ -0,0 +1,368 @@+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.ParseUtils+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Parsing utilities.+-----------------------------------------------------------------------------++module Distribution.Client.ParseUtils (++    -- * Fields and field utilities+    FieldDescr(..),+    liftField,+    liftFields,+    filterFields,+    mapFieldNames,+    commandOptionToField,+    commandOptionsToFields,++    -- * Sections and utilities+    SectionDescr(..),+    liftSection,++    -- * FieldGrammar sections+    FGSectionDescr(..),++    -- * Parsing and printing flat config+    parseFields,+    ppFields,+    ppSection,++    -- * Parsing and printing config with sections and subsections+    parseFieldsAndSections,+    ppFieldsAndSections,++    -- ** Top level of config files+    parseConfig,+    showConfig,+  )+       where++import Distribution.Client.Compat.Prelude hiding (empty, get)+import Prelude ()++import Distribution.Deprecated.ParseUtils+         ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo+         , Field(..), liftField, readFields )+import Distribution.Deprecated.ViewAsFieldDescr+         ( viewAsFieldDescr )++import Distribution.Simple.Command+         ( OptionField  )++import Text.PrettyPrint ( ($+$) )+import qualified Data.ByteString as BS+import qualified Data.Map as Map+import qualified Text.PrettyPrint as Disp+         ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )++-- For new parser stuff+import Distribution.CabalSpecVersion (cabalSpecLatest)+import Distribution.FieldGrammar (partitionFields, parseFieldGrammar)+import Distribution.Fields.ParseResult (runParseResult)+import Distribution.Parsec.Error (showPError)+import Distribution.Parsec.Position (Position (..))+import Distribution.Parsec.Warning (showPWarning)+import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)+import qualified Distribution.Fields as F+import qualified Distribution.FieldGrammar as FG+++-------------------------+-- FieldDescr utilities+--++liftFields :: (b -> a)+           -> (a -> b -> b)+           -> [FieldDescr a]+           -> [FieldDescr b]+liftFields get set = map (liftField get set)+++-- | Given a collection of field descriptions, keep only a given list of them,+-- identified by name.+--+filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]+filterFields includeFields = filter ((`elem` includeFields) . fieldName)++-- | Apply a name mangling function to the field names of all the field+-- descriptions. The typical use case is to apply some prefix.+--+mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]+mapFieldNames mangleName =+    map (\descr -> descr { fieldName = mangleName (fieldName descr) })+++-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.+--+commandOptionToField :: OptionField a -> FieldDescr a+commandOptionToField = viewAsFieldDescr++-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.+--+commandOptionsToFields :: [OptionField a] -> [FieldDescr a]+commandOptionsToFields = map viewAsFieldDescr+++------------------------------------------+-- SectionDescr definition and utilities+--++-- | The description of a section in a config file. It can contain both+-- fields and optionally further subsections. See also 'FieldDescr'.+--+data SectionDescr a = forall b. SectionDescr {+       sectionName        :: String,+       sectionFields      :: [FieldDescr b],+       sectionSubsections :: [SectionDescr b],+       sectionGet         :: a -> [(String, b)],+       sectionSet         :: LineNo -> String -> b -> a -> ParseResult a,+       sectionEmpty       :: b+     }++-- | 'FieldGrammar' section description+data FGSectionDescr g a = forall s. FGSectionDescr+    { fgSectionName    :: String+    , fgSectionGrammar :: g s s+    -- todo: add subsections?+    , fgSectionGet     :: a -> [(String, s)]+    , fgSectionSet     :: LineNo -> String -> s -> a -> ParseResult a+    }++-- | To help construction of config file descriptions in a modular way it is+-- useful to define fields and sections on local types and then hoist them+-- into the parent types when combining them in bigger descriptions.+--+-- This is essentially a lens operation for 'SectionDescr' to help embedding+-- one inside another.+--+liftSection :: (b -> a)+            -> (a -> b -> b)+            -> SectionDescr a+            -> SectionDescr b+liftSection get' set' (SectionDescr name fields sections get set empty) =+    let sectionGet' = get . get'+        sectionSet' lineno param x y = do+          x' <- set lineno param x (get' y)+          return (set' x' y)+     in SectionDescr name fields sections sectionGet' sectionSet' empty+++-------------------------------------+-- Parsing and printing flat config+--++-- | Parse a bunch of semi-parsed 'Field's according to a set of field+-- descriptions. It accumulates the result on top of a given initial value.+--+-- This only covers the case of flat configuration without subsections. See+-- also 'parseFieldsAndSections'.+--+parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a+parseFields fieldDescrs =+    foldM setField+  where+    fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]++    setField accum (F line name value) =+      case Map.lookup name fieldMap of+        Just (FieldDescr _ _ set) -> set line value accum+        Nothing -> do+          warning $ "Unrecognized field " ++ name ++ " on line " ++ show line+          return accum++    setField accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++-- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils+-- that also optionally print default values for empty fields as comments.+--+ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+ppFields fields def cur =+    Disp.vcat [ ppField name (fmap getter def) (getter cur)+              | FieldDescr name getter _ <- fields]++ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc+ppField name mdef cur+  | Disp.isEmpty cur = maybe Disp.empty+                       (\def -> Disp.text "--" <+> Disp.text name+                                Disp.<> Disp.colon <+> def) mdef+  | otherwise        = Disp.text name Disp.<> Disp.colon <+> cur++-- | Pretty print a section.+--+-- Since 'ppFields' does not cover subsections you can use this to add them.+-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.+--+ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+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+++-----------------------------------------+-- Parsing and printing non-flat config+--++-- | Much like 'parseFields' but it also allows subsections. The permitted+-- subsections are given by a list of 'SectionDescr's.+--+parseFieldsAndSections+    :: [FieldDescr a]      -- ^ field+    -> [SectionDescr a]    -- ^ legacy sections+    -> [FGSectionDescr FG.ParsecFieldGrammar a]  -- ^ FieldGrammar sections+    -> a+    -> [Field] -> ParseResult a+parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =+    foldM setField+  where+    fieldMap     = Map.fromList [ (fieldName     f, f) | f <- fieldDescrs     ]+    sectionMap   = Map.fromList [ (sectionName   s, s) | s <- sectionDescrs   ]+    fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ]++    setField a (F line name value) =+      case Map.lookup name fieldMap of+        Just (FieldDescr _ _ set) -> set line value a+        Nothing -> do+          warning $ "Unrecognized field '" ++ name+                 ++ "' on line " ++ show line+          return a++    setField a (Section line name param fields) =+      case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of+        Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do+          b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields+          set line param b a+        Just (Right (FGSectionDescr _ grammar _getter setter)) -> do+          let fields1 = map convertField fields+              (fields2, sections) = partitionFields fields1+          -- TODO: recurse into sections+          for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->+            warning $ "Unrecognized section '" ++ fromUTF8BS name'+              ++ "' on line " ++ show line'+          case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of+            (warnings, Right b) -> do+              for_ warnings $ \w -> warning $ showPWarning "???" w+              setter line param b a+            (warnings, Left (_, errs)) -> do+              for_ warnings $ \w -> warning $ showPWarning "???" w+              case errs of+                err :| _errs -> fail $ showPError "???" err+        Nothing -> do+          warning $ "Unrecognized section '" ++ name+                 ++ "' on line " ++ show line+          return a++convertField :: Field -> F.Field Position+convertField (F line name str) =+    F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]+  where+    pos = Position line 0+-- arguments omitted+convertField (Section line name _arg fields) =+    F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)+  where+    pos = Position line 0++-- | Much like 'ppFields' but also pretty prints any subsections. Subsection+-- are only shown if they are non-empty.+--+-- Note that unlike 'ppFields', at present it does not support printing+-- default values. If needed, adding such support would be quite reasonable.+--+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc+ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =+    ppFields fieldDescrs Nothing val+      $+$+    Disp.vcat (+      [ Disp.text "" $+$ sectionDoc+      | SectionDescr {+          sectionName, sectionGet,+          sectionFields, sectionSubsections+        } <- sectionDescrs+      , (param, x) <- sectionGet val+      , let sectionDoc = ppSectionAndSubsections+                           sectionName param+                           sectionFields sectionSubsections [] x+      , not (Disp.isEmpty sectionDoc)+      ] +++      [ Disp.text "" $+$ sectionDoc+      | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs+      , (param, x) <- fgSectionGet val+      , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x+      , not (Disp.isEmpty sectionDoc)+      ])++-- | Unlike 'ppSection' which has to be called directly, this gets used via+-- 'ppFieldsAndSections' and so does not need to be exported.+--+ppSectionAndSubsections :: String -> String+                        -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar  a] -> a -> Disp.Doc+ppSectionAndSubsections name arg fields sections fgSections cur+  | Disp.isEmpty fieldsDoc = Disp.empty+  | otherwise              = Disp.text name <+> argDoc+                             $+$ (Disp.nest 2 fieldsDoc)+  where+    fieldsDoc = showConfig fields sections fgSections cur+    argDoc | arg == "" = Disp.empty+           | otherwise = Disp.text arg++-- |+--+-- TODO: subsections+-- TODO: this should simply build 'PrettyField'+ppFgSection+    :: String  -- ^ section name+    -> String  -- ^ parameter+    -> FG.PrettyFieldGrammar a a+    -> a+    -> Disp.Doc+ppFgSection secName arg grammar x+    | null prettyFields = Disp.empty+    | otherwise         =+        Disp.text secName <+> argDoc+        $+$ (Disp.nest 2 fieldsDoc)+  where+    prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x++    argDoc | arg == "" = Disp.empty+           | otherwise = Disp.text arg++    fieldsDoc = Disp.vcat+        [ Disp.text fname' <<>> Disp.colon <<>> doc+        | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections+        , let fname' = fromUTF8BS fname+        ]+++-----------------------------------------------+-- Top level config file parsing and printing+--++-- | Parse a string in the config file syntax into a value, based on a+-- description of the configuration file in terms of its fields and sections.+--+-- It accumulates the result on top of a given initial (typically empty) value.+--+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a+            -> BS.ByteString -> ParseResult a+parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =+      parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty+  =<< readFields str++-- | Render a value in the config file syntax, based on a description of the+-- configuration file in terms of its fields and sections.+--+showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc+showConfig = ppFieldsAndSections+
+ src/Distribution/Client/ProjectBuilding.hs view
@@ -0,0 +1,1489 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE NoMonoLocalBinds    #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++-- |+--+module Distribution.Client.ProjectBuilding (+    -- * Dry run phase+    -- | What bits of the plan will we execute? The dry run does not change+    -- anything but tells us what will need to be built.+    rebuildTargetsDryRun,+    improveInstallPlanWithUpToDatePackages,++    -- ** Build status+    -- | This is the detailed status information we get from the dry run.+    BuildStatusMap,+    BuildStatus(..),+    BuildStatusRebuild(..),+    BuildReason(..),+    MonitorChangedReason(..),+    buildStatusToString,++    -- * Build phase+    -- | Now we actually execute the plan.+    rebuildTargets,+    -- ** Build outcomes+    -- | This is the outcome for each package of executing the plan.+    -- For each package, did the build succeed or fail?+    BuildOutcomes,+    BuildOutcome,+    BuildResult(..),+    BuildFailure(..),+    BuildFailureReason(..),+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import           Distribution.Client.PackageHash (renderPackageHashInputs)+import           Distribution.Client.RebuildMonad+import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanning+import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.ProjectBuilding.Types+import           Distribution.Client.Store++import           Distribution.Client.Types+                   hiding (BuildOutcomes, BuildOutcome,+                           BuildResult(..), BuildFailure(..))+import           Distribution.Client.InstallPlan+                   ( GenericInstallPlan, GenericPlanPackage, IsUnit )+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.DistDirLayout+import           Distribution.Client.FileMonitor+import           Distribution.Client.SetupWrapper+import           Distribution.Client.JobControl+import           Distribution.Client.FetchUtils+import           Distribution.Client.GlobalFlags (RepoContext)+import qualified Distribution.Client.Tar as Tar+import           Distribution.Client.Setup+                   ( filterConfigureFlags, filterHaddockArgs+                   , filterHaddockFlags, filterTestFlags )+import           Distribution.Client.SourceFiles+import           Distribution.Client.SrcDist (allPackageSourceFiles)+import           Distribution.Client.Utils+                   ( ProgressPhase(..), progressMessage, removeExistingFile )++import           Distribution.Compat.Lens+import           Distribution.Package+import qualified Distribution.PackageDescription as PD+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.InstalledPackageInfo as Installed+import           Distribution.Simple.BuildPaths (haddockDirName)+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Types.BuildType+import           Distribution.Types.PackageDescription.Lens (componentModules)+import           Distribution.Simple.Program+import qualified Distribution.Simple.Setup as Cabal+import           Distribution.Simple.Command (CommandUI)+import qualified Distribution.Simple.Register as Cabal+import           Distribution.Simple.LocalBuildInfo+                   ( ComponentName(..), LibraryName(..) )+import           Distribution.Simple.Compiler+                   ( Compiler, compilerId, PackageDB(..) )++import           Distribution.Simple.Utils+import           Distribution.Version+import           Distribution.Compat.Graph (IsNode(..))++import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS++import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)+import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)+import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))+import System.IO         (IOMode (AppendMode), withFile)++import Distribution.Compat.Directory (listDirectory)+++------------------------------------------------------------------------------+-- * Overall building strategy.+------------------------------------------------------------------------------+--+-- We start with an 'ElaboratedInstallPlan' that has already been improved by+-- reusing packages from the store, and pruned to include only the targets of+-- interest and their dependencies. So the remaining packages in the+-- 'InstallPlan.Configured' state are ones we either need to build or rebuild.+--+-- First, we do a preliminary dry run phase where we work out which packages+-- we really need to (re)build, and for the ones we do need to build which+-- build phase to start at.+--+-- We use this to improve the 'ElaboratedInstallPlan' again by changing+-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'+-- so that the build phase will skip them.+--+-- Then we execute the plan, that is actually build packages. The outcomes of+-- trying to build all the packages are collected and returned.+--+-- We split things like this (dry run and execute) for a couple reasons.+-- Firstly we need to be able to do dry runs anyway, and these need to be+-- reasonably accurate in terms of letting users know what (and why) things+-- are going to be (re)built.+--+-- Given that we need to be able to do dry runs, it would not be great if+-- we had to repeat all the same work when we do it for real. Not only is+-- it duplicate work, but it's duplicate code which is likely to get out of+-- sync. So we do things only once. We preserve info we discover in the dry+-- run phase and rely on it later when we build things for real. This also+-- somewhat simplifies the build phase. So this way the dry run can't so+-- easily drift out of sync with the real thing since we're relying on the+-- info it produces.+--+-- An additional advantage is that it makes it easier to debug rebuild+-- errors (ie rebuilding too much or too little), since all the rebuild+-- decisions are made without making any state changes at the same time+-- (that would make it harder to reproduce the problem situation).+--+-- Finally, we can use the dry run build status and the build outcomes to+-- give us some information on the overall status of packages in the project.+-- This includes limited information about the status of things that were+-- not actually in the subset of the plan that was used for the dry run or+-- execution phases. In particular we may know that some packages are now+-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for+-- details.+++------------------------------------------------------------------------------+-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?+------------------------------------------------------------------------------++-- Refer to ProjectBuilding.Types for details of these important types:++-- type BuildStatusMap     = ...+-- data BuildStatus        = ...+-- data BuildStatusRebuild = ...+-- data BuildReason        = ...++-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.+--+-- It gives us the 'BuildStatusMap'. This should be used with+-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of+-- the 'ElaboratedInstallPlan' with packages switched to the+-- 'InstallPlan.Installed' state when we find that they're already up to date.+--+rebuildTargetsDryRun :: DistDirLayout+                     -> ElaboratedSharedConfig+                     -> ElaboratedInstallPlan+                     -> IO BuildStatusMap+rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =+    -- Do the various checks to work out the 'BuildStatus' of each package+    foldMInstallPlanDepOrder dryRunPkg+  where+    dryRunPkg :: ElaboratedPlanPackage+              -> [BuildStatus]+              -> IO BuildStatus+    dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =+      return BuildStatusPreExisting++    dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =+      return BuildStatusInstalled++    dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do+      mloc <- checkFetched (elabPkgSourceLocation pkg)+      case mloc of+        Nothing -> return BuildStatusDownload++        Just (LocalUnpackedPackage srcdir) ->+          -- For the case of a user-managed local dir, irrespective of the+          -- build style, we build from that directory and put build+          -- artifacts under the shared dist directory.+          dryRunLocalPkg pkg depsBuildStatus srcdir++        -- The rest cases are all tarball cases are,+        -- and handled the same as each other though depending on the build style.+        Just (LocalTarballPackage    tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++        Just (RemoteTarballPackage _ tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++        Just (RepoTarballPackage _ _ tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball++        Just (RemoteSourceRepoPackage _repo tarball) ->+          dryRunTarballPkg pkg depsBuildStatus tarball+++    dryRunTarballPkg :: ElaboratedConfiguredPackage+                     -> [BuildStatus]+                     -> FilePath+                     -> IO BuildStatus+    dryRunTarballPkg pkg depsBuildStatus tarball =+      case elabBuildStyle pkg of+        BuildAndInstall  -> return (BuildStatusUnpack tarball)+        BuildInplaceOnly -> do+          -- TODO: [nice to have] use a proper file monitor rather+          -- than this dir exists test+          exists <- doesDirectoryExist srcdir+          if exists+            then dryRunLocalPkg pkg depsBuildStatus srcdir+            else return (BuildStatusUnpack tarball)+      where+        srcdir = distUnpackedSrcDirectory (packageId pkg)++    dryRunLocalPkg :: ElaboratedConfiguredPackage+                   -> [BuildStatus]+                   -> FilePath+                   -> IO BuildStatus+    dryRunLocalPkg pkg depsBuildStatus srcdir = do+        -- Go and do lots of I/O, reading caches and probing files to work out+        -- if anything has changed+        change <- checkPackageFileMonitorChanged+                    packageFileMonitor pkg srcdir depsBuildStatus+        case change of+          -- It did change, giving us 'BuildStatusRebuild' info on why+          Left rebuild ->+            return (BuildStatusRebuild srcdir rebuild)++          -- No changes, the package is up to date. Use the saved build results.+          Right buildResult ->+            return (BuildStatusUpToDate buildResult)+      where+        packageFileMonitor =+          newPackageFileMonitor shared distDirLayout+          (elabDistDirParams shared pkg)+++-- | A specialised traversal over the packages in an install plan.+--+-- The packages are visited in dependency order, starting with packages with no+-- dependencies. The result for each package is accumulated into a 'Map' and+-- returned as the final result. In addition, when visiting a package, the+-- visiting function is passed the results for all the immediate package+-- dependencies. This can be used to propagate information from dependencies.+--+foldMInstallPlanDepOrder+  :: forall m ipkg srcpkg b.+     (Monad m, IsUnit ipkg, IsUnit srcpkg)+  => (GenericPlanPackage ipkg srcpkg ->+      [b] -> m b)+  -> GenericInstallPlan ipkg srcpkg+  -> m (Map UnitId b)+foldMInstallPlanDepOrder visit =+    go Map.empty . InstallPlan.reverseTopologicalOrder+  where+    go :: Map UnitId b+       -> [GenericPlanPackage ipkg srcpkg]+       -> m (Map UnitId b)+    go !results [] = return results++    go !results (pkg : pkgs) = do+      -- we go in the right order so the results map has entries for all deps+      let depresults :: [b]+          depresults =+            map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results+                              in result)+                (InstallPlan.depends pkg)+      result <- visit pkg depresults+      let results' = Map.insert (nodeKey pkg) result results+      go results' pkgs++improveInstallPlanWithUpToDatePackages :: BuildStatusMap+                                       -> ElaboratedInstallPlan+                                       -> ElaboratedInstallPlan+improveInstallPlanWithUpToDatePackages pkgsBuildStatus =+    InstallPlan.installed canPackageBeImproved+  where+    canPackageBeImproved pkg =+      case Map.lookup (installedUnitId pkg) pkgsBuildStatus of+        Just BuildStatusUpToDate {} -> True+        Just _                      -> False+        Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "+                        ++ prettyShow (packageId pkg) ++ " not in status map"+++-----------------------------+-- Package change detection+--++-- | As part of the dry run for local unpacked packages we have to check if the+-- package config or files have changed. That is the purpose of+-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.+--+-- When a package is (re)built, the monitor must be updated to reflect the new+-- state of the package. Because we sometimes build without reconfiguring the+-- state updates are split into two, one for package config changes and one+-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'+-- and 'updatePackageBuildFileMonitor'.+--+data PackageFileMonitor = PackageFileMonitor {+       pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),+       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,+       pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)+     }++-- | This is all the components of the 'BuildResult' other than the+-- @['InstalledPackageInfo']@.+--+-- We have to split up the 'BuildResult' components since they get produced+-- at different times (or rather, when different things change).+--+type BuildResultMisc = (DocsResult, TestsResult)++newPackageFileMonitor :: ElaboratedSharedConfig+                      -> DistDirLayout+                      -> DistDirParams+                      -> PackageFileMonitor+newPackageFileMonitor shared+                      DistDirLayout{distPackageCacheFile}+                      dparams =+    PackageFileMonitor {+      pkgFileMonitorConfig =+        FileMonitor {+          fileMonitorCacheFile = distPackageCacheFile dparams "config",+          fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared,+          fileMonitorCheckIfOnlyValueChanged = False+        },++      pkgFileMonitorBuild =+        FileMonitor {+          fileMonitorCacheFile = distPackageCacheFile dparams "build",+          fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->+            componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,+          fileMonitorCheckIfOnlyValueChanged = True+        },++      pkgFileMonitorReg =+        newFileMonitor (distPackageCacheFile dparams "registration")+    }++-- | Helper function for 'checkPackageFileMonitorChanged',+-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.+--+-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by+-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.+--+packageFileMonitorKeyValues :: ElaboratedConfiguredPackage+                            -> (ElaboratedConfiguredPackage, Set ComponentName)+packageFileMonitorKeyValues elab =+    (elab_config, buildComponents)+  where+    -- The first part is the value used to guard (re)configuring the package.+    -- That is, if this value changes then we will reconfigure.+    -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of+    -- information that affects the (re)configure step. But those parts that+    -- do not affect the configure step need to be nulled out. Those parts are+    -- the specific targets that we're going to build.+    --+    elab_config =+        elab {+            elabBuildTargets   = [],+            elabTestTargets    = [],+            elabBenchTargets   = [],+            elabReplTarget     = Nothing,+            elabHaddockTargets = [],+            elabBuildHaddocks  = False+        }++    -- The second part is the value used to guard the build step. So this is+    -- more or less the opposite of the first part, as it's just the info about+    -- what targets we're going to build.+    --+    buildComponents = elabBuildTargetWholeComponents elab++-- | Do all the checks on whether a package has changed and thus needs either+-- rebuilding or reconfiguring and rebuilding.+--+checkPackageFileMonitorChanged :: PackageFileMonitor+                               -> ElaboratedConfiguredPackage+                               -> FilePath+                               -> [BuildStatus]+                               -> IO (Either BuildStatusRebuild BuildResult)+checkPackageFileMonitorChanged PackageFileMonitor{..}+                               pkg srcdir depsBuildStatus = do+    --TODO: [nice to have] some debug-level message about file+    --changes, like rerunIfChanged+    configChanged <- checkFileMonitorChanged+                       pkgFileMonitorConfig srcdir pkgconfig+    case configChanged of+      MonitorChanged monitorReason ->+          return (Left (BuildStatusConfigure monitorReason'))+        where+          monitorReason' = fmap (const ()) monitorReason++      MonitorUnchanged () _+          -- The configChanged here includes the identity of the dependencies,+          -- so depsBuildStatus is just needed for the changes in the content+          -- of dependencies.+        | any buildStatusRequiresBuild depsBuildStatus -> do+            regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()+            let mreg = changedToMaybe regChanged+            return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))++        | otherwise -> do+            buildChanged  <- checkFileMonitorChanged+                               pkgFileMonitorBuild srcdir buildComponents+            regChanged    <- checkFileMonitorChanged+                               pkgFileMonitorReg srcdir ()+            let mreg = changedToMaybe regChanged+            case (buildChanged, regChanged) of+              (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->+                  return (Left (BuildStatusBuild mreg buildReason))+                where+                  buildReason = BuildReasonExtraTargets prevBuildComponents++              (MonitorChanged monitorReason, _) ->+                  return (Left (BuildStatusBuild mreg buildReason))+                where+                  buildReason    = BuildReasonFilesChanged monitorReason'+                  monitorReason' = fmap (const ()) monitorReason++              (MonitorUnchanged _ _, MonitorChanged monitorReason) ->+                -- this should only happen if the file is corrupt or been+                -- manually deleted. We don't want to bother with another+                -- phase just for this, so we'll reregister by doing a build.+                  return (Left (BuildStatusBuild Nothing buildReason))+                where+                  buildReason    = BuildReasonFilesChanged monitorReason'+                  monitorReason' = fmap (const ()) monitorReason++              (MonitorUnchanged _ _, MonitorUnchanged _ _)+                | pkgHasEphemeralBuildTargets pkg ->+                  return (Left (BuildStatusBuild mreg buildReason))+                where+                  buildReason = BuildReasonEphemeralTargets++              (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->+                  return $ Right BuildResult {+                    buildResultDocs    = docsResult,+                    buildResultTests   = testsResult,+                    buildResultLogFile = Nothing+                  }+                where+                  (docsResult, testsResult) = buildResult+  where+    (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg+    changedToMaybe (MonitorChanged     _) = Nothing+    changedToMaybe (MonitorUnchanged x _) = Just x+++updatePackageConfigFileMonitor :: PackageFileMonitor+                               -> FilePath+                               -> ElaboratedConfiguredPackage+                               -> IO ()+updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}+                               srcdir pkg =+    updateFileMonitor pkgFileMonitorConfig srcdir Nothing+                      [] pkgconfig ()+  where+    (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg++updatePackageBuildFileMonitor :: PackageFileMonitor+                              -> FilePath+                              -> MonitorTimestamp+                              -> ElaboratedConfiguredPackage+                              -> BuildStatusRebuild+                              -> [MonitorFilePath]+                              -> BuildResultMisc+                              -> IO ()+updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}+                              srcdir timestamp pkg pkgBuildStatus+                              monitors buildResult =+    updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)+                      monitors buildComponents' buildResult+  where+    (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg++    -- If the only thing that's changed is that we're now building extra+    -- components, then we can avoid later unnecessary rebuilds by saving the+    -- total set of components that have been built, namely the union of the+    -- existing ones plus the new ones. If files also changed this would be+    -- the wrong thing to do. Note that we rely on the+    -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee+    -- that it's /only/ the value that changed not any files that changed.+    buildComponents' =+      case pkgBuildStatus of+        BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)+          -> buildComponents `Set.union` prevBuildComponents+        _ -> buildComponents++updatePackageRegFileMonitor :: PackageFileMonitor+                            -> FilePath+                            -> Maybe InstalledPackageInfo+                            -> IO ()+updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}+                            srcdir mipkg =+    updateFileMonitor pkgFileMonitorReg srcdir Nothing+                      [] () mipkg++invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()+invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =+    removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)+++------------------------------------------------------------------------------+-- * Doing it: executing an 'ElaboratedInstallPlan'+------------------------------------------------------------------------------++-- Refer to ProjectBuilding.Types for details of these important types:++-- type BuildOutcomes = ...+-- type BuildOutcome  = ...+-- data BuildResult   = ...+-- data BuildFailure  = ...+-- data BuildFailureReason = ...++-- | Build things for real.+--+-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.+--+rebuildTargets :: Verbosity+               -> DistDirLayout+               -> StoreDirLayout+               -> ElaboratedInstallPlan+               -> ElaboratedSharedConfig+               -> BuildStatusMap+               -> BuildTimeSettings+               -> IO BuildOutcomes+rebuildTargets verbosity+               distDirLayout@DistDirLayout{..}+               storeDirLayout+               installPlan+               sharedPackageConfig@ElaboratedSharedConfig {+                 pkgConfigCompiler      = compiler,+                 pkgConfigCompilerProgs = progdb+               }+               pkgsBuildStatus+               buildSettings@BuildTimeSettings{+                 buildSettingNumJobs,+                 buildSettingKeepGoing+               } = do++    -- Concurrency control: create the job controller and concurrency limits+    -- for downloading, building and installing.+    jobControl    <- if isParallelBuild+                       then newParallelJobControl buildSettingNumJobs+                       else newSerialJobControl+    registerLock  <- newLock -- serialise registration+    cacheLock     <- newLock -- serialise access to setup exe cache+                             --TODO: [code cleanup] eliminate setup exe cache++    debug verbosity $+        "Executing install plan "+     ++ if isParallelBuild+          then " in parallel using " ++ show buildSettingNumJobs ++ " threads."+          else " serially."++    createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory+    createDirectoryIfMissingVerbose verbosity True distTempDirectory+    traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse++    -- Before traversing the install plan, pre-emptively find all packages that+    -- will need to be downloaded and start downloading them.+    asyncDownloadPackages verbosity withRepoCtx+                          installPlan pkgsBuildStatus $ \downloadMap ->++      -- For each package in the plan, in dependency order, but in parallel...+      InstallPlan.execute jobControl keepGoing+                          (BuildFailure Nothing . DependentFailed . packageId)+                          installPlan $ \pkg ->+        --TODO: review exception handling+        handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $++        let uid = installedUnitId pkg+            pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in++        rebuildTarget+          verbosity+          distDirLayout+          storeDirLayout+          buildSettings downloadMap+          registerLock cacheLock+          sharedPackageConfig+          installPlan pkg+          pkgBuildStatus+  where+    isParallelBuild = buildSettingNumJobs >= 2+    keepGoing       = buildSettingKeepGoing+    withRepoCtx     = projectConfigWithBuilderRepoContext verbosity+                        buildSettings+    packageDBsToUse = -- all the package dbs we may need to create+      (Set.toList . Set.fromList)+        [ pkgdb+        | InstallPlan.Configured elab <- InstallPlan.toList installPlan+        , pkgdb <- concat [ elabBuildPackageDBStack elab+                          , elabRegisterPackageDBStack elab+                          , elabSetupPackageDBStack elab ]+        ]+++-- | Create a package DB if it does not currently exist. Note that this action+-- is /not/ safe to run concurrently.+--+createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb+                         -> PackageDB -> IO ()+createPackageDBIfMissing verbosity compiler progdb+                         (SpecificPackageDB dbPath) = do+    exists <- Cabal.doesPackageDBExist dbPath+    unless exists $ do+      createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)+      Cabal.createPackageDB verbosity compiler progdb False dbPath+createPackageDBIfMissing _ _ _ _ = return ()+++-- | Given all the context and resources, (re)build an individual package.+--+rebuildTarget :: Verbosity+              -> DistDirLayout+              -> StoreDirLayout+              -> BuildTimeSettings+              -> AsyncFetchMap+              -> Lock -> Lock+              -> ElaboratedSharedConfig+              -> ElaboratedInstallPlan+              -> ElaboratedReadyPackage+              -> BuildStatus+              -> IO BuildResult+rebuildTarget verbosity+              distDirLayout@DistDirLayout{distBuildDirectory}+              storeDirLayout+              buildSettings downloadMap+              registerLock cacheLock+              sharedPackageConfig+              plan rpkg@(ReadyPackage pkg)+              pkgBuildStatus+    -- Technically, doing the --only-download filtering only in this function is+    -- not perfect. We could also prune the plan at an earlier stage, like it's+    -- done with --only-dependencies. But...+    --   * the benefit would be minimal (practically just avoiding to print the+    --     "requires build" parts of the plan)+    --   * we currently don't have easy access to the BuildStatus of packages+    --     in the pruning phase+    --   * we still have to check it here to avoid performing successive phases+    | buildSettingOnlyDownload buildSettings = do+        case pkgBuildStatus of+          BuildStatusDownload ->+            void $ waitAsyncPackageDownload verbosity downloadMap pkg+          _ -> return ()+        return $ BuildResult DocsNotTried TestsNotTried Nothing+    | otherwise =+    -- We rely on the 'BuildStatus' to decide which phase to start from:+    case pkgBuildStatus of+      BuildStatusDownload              -> downloadPhase+      BuildStatusUnpack tarball        -> unpackTarballPhase tarball+      BuildStatusRebuild srcdir status -> rebuildPhase status srcdir++      -- TODO: perhaps re-nest the types to make these impossible+      BuildStatusPreExisting {} -> unexpectedState+      BuildStatusInstalled   {} -> unexpectedState+      BuildStatusUpToDate    {} -> unexpectedState+  where+    unexpectedState = error "rebuildTarget: unexpected package status"++    downloadPhase = do+        downsrcloc <- annotateFailureNoLog DownloadFailed $+                        waitAsyncPackageDownload verbosity downloadMap pkg+        case downsrcloc of+          DownloadedTarball tarball -> unpackTarballPhase tarball+          --TODO: [nice to have] git/darcs repos etc+++    unpackTarballPhase tarball =+        withTarballLocalDirectory+          verbosity distDirLayout tarball+          (packageId pkg) (elabDistDirParams sharedPackageConfig pkg)+          (elabBuildStyle pkg)+          (elabPkgDescriptionOverride pkg) $++          case elabBuildStyle pkg of+            BuildAndInstall  -> buildAndInstall+            BuildInplaceOnly -> buildInplace buildStatus+              where+                buildStatus = BuildStatusConfigure MonitorFirstRun++    -- Note that this really is rebuild, not build. It can only happen for+    -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages+    -- would only start from download or unpack phases.+    --+    rebuildPhase buildStatus srcdir =+        assert (elabBuildStyle pkg == BuildInplaceOnly) $++          buildInplace buildStatus srcdir builddir+      where+        builddir = distBuildDirectory+                   (elabDistDirParams sharedPackageConfig pkg)++    buildAndInstall srcdir builddir =+        buildAndInstallUnpackedPackage+          verbosity distDirLayout storeDirLayout+          buildSettings registerLock cacheLock+          sharedPackageConfig+          plan rpkg+          srcdir builddir'+      where+        builddir' = makeRelative srcdir builddir+        --TODO: [nice to have] ^^ do this relative stuff better++    buildInplace buildStatus srcdir builddir =+        --TODO: [nice to have] use a relative build dir rather than absolute+        buildInplaceUnpackedPackage+          verbosity distDirLayout+          buildSettings registerLock cacheLock+          sharedPackageConfig+          plan rpkg+          buildStatus+          srcdir builddir++-- TODO: [nice to have] do we need to use a with-style for the temp+-- files for downloading http packages, or are we going to cache them+-- persistently?++-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the+-- packages we have to download and fork off an async action to download them.+-- We download them in dependency order so that the one's we'll need+-- first are the ones we will start downloading first.+--+-- The body action is passed a map from those packages (identified by their+-- location) to a completion var for that package. So the body action should+-- lookup the location and use 'waitAsyncPackageDownload' to get the result.+--+asyncDownloadPackages :: Verbosity+                      -> ((RepoContext -> IO a) -> IO a)+                      -> ElaboratedInstallPlan+                      -> BuildStatusMap+                      -> (AsyncFetchMap -> IO a)+                      -> IO a+asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body+  | null pkgsToDownload = body Map.empty+  | otherwise           = withRepoCtx $ \repoctx ->+                            asyncFetchPackages verbosity repoctx+                                               pkgsToDownload body+  where+    pkgsToDownload =+      ordNub $+      [ elabPkgSourceLocation elab+      | InstallPlan.Configured elab+         <- InstallPlan.reverseTopologicalOrder installPlan+      , let uid = installedUnitId elab+            pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus+      , BuildStatusDownload <- [pkgBuildStatus]+      ]+++-- | Check if a package needs downloading, and if so expect to find a download+-- in progress in the given 'AsyncFetchMap' and wait on it to finish.+--+waitAsyncPackageDownload :: Verbosity+                         -> AsyncFetchMap+                         -> ElaboratedConfiguredPackage+                         -> IO DownloadedSourceLocation+waitAsyncPackageDownload verbosity downloadMap elab = do+    pkgloc <- waitAsyncFetchPackage verbosity downloadMap+                                    (elabPkgSourceLocation elab)+    case downloadedSourceLocation pkgloc of+      Just loc -> return loc+      Nothing  -> fail "waitAsyncPackageDownload: unexpected source location"++data DownloadedSourceLocation = DownloadedTarball FilePath+                              --TODO: [nice to have] git/darcs repos etc++downloadedSourceLocation :: PackageLocation FilePath+                         -> Maybe DownloadedSourceLocation+downloadedSourceLocation pkgloc =+    case pkgloc of+      RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)+      RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)+      _                              -> Nothing+++++-- | Ensure that the package is unpacked in an appropriate directory, either+-- a temporary one or a persistent one under the shared dist directory.+--+withTarballLocalDirectory+  :: Verbosity+  -> DistDirLayout+  -> FilePath+  -> PackageId+  -> DistDirParams+  -> BuildStyle+  -> Maybe CabalFileText+  -> (FilePath -> -- Source directory+      FilePath -> -- Build directory+      IO a)+  -> IO a+withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}+                          tarball pkgid dparams buildstyle pkgTextOverride+                          buildPkg  =+      case buildstyle of+        -- In this case we make a temp dir (e.g. tmp/src2345/), unpack+        -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for+        -- compatibility we put the dist dir within it+        -- (i.e. tmp/src2345/foo-1.0/dist/).+        --+        -- Unfortunately, a few custom Setup.hs scripts do not respect+        -- the --builddir flag and always look for it at ./dist/ so+        -- this way we avoid breaking those packages+        BuildAndInstall ->+          let tmpdir = distTempDirectory in+          withTempDirectory verbosity tmpdir "src"   $ \unpackdir -> do+            unpackPackageTarball verbosity tarball unpackdir+                                 pkgid pkgTextOverride+            let srcdir   = unpackdir </> prettyShow pkgid+                builddir = srcdir </> "dist"+            buildPkg srcdir builddir++        -- In this case we make sure the tarball has been unpacked to the+        -- appropriate location under the shared dist dir, and then build it+        -- inplace there+        BuildInplaceOnly -> do+          let srcrootdir = distUnpackedSrcRootDirectory+              srcdir     = distUnpackedSrcDirectory pkgid+              builddir   = distBuildDirectory dparams+          -- TODO: [nice to have] use a proper file monitor rather+          -- than this dir exists test+          exists <- doesDirectoryExist srcdir+          unless exists $ do+            createDirectoryIfMissingVerbose verbosity True srcrootdir+            unpackPackageTarball verbosity tarball srcrootdir+                                 pkgid pkgTextOverride+            moveTarballShippedDistDirectory verbosity distDirLayout+                                            srcrootdir pkgid dparams+          buildPkg srcdir builddir+++unpackPackageTarball :: Verbosity -> FilePath -> FilePath+                     -> PackageId -> Maybe CabalFileText+                     -> IO ()+unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =+    --TODO: [nice to have] switch to tar package and catch tar exceptions+    annotateFailureNoLog UnpackFailed $ do++      -- Unpack the tarball+      --+      info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."+      Tar.extractTarGzFile parentdir pkgsubdir tarball++      -- Sanity check+      --+      exists <- doesFileExist cabalFile+      unless exists $+        die' verbosity $+        "Package .cabal file not found in the tarball: " ++ cabalFile++      -- Overwrite the .cabal with the one from the index, when appropriate+      --+      case pkgTextOverride of+        Nothing     -> return ()+        Just pkgtxt -> do+          info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal"+                        ++ " with the latest revision from the index."+          writeFileAtomic cabalFile pkgtxt++  where+    cabalFile = parentdir </> pkgsubdir+                          </> prettyShow pkgname <.> "cabal"+    pkgsubdir = prettyShow pkgid+    pkgname   = packageName pkgid+++-- | This is a bit of a hacky workaround. A number of packages ship+-- pre-processed .hs files in a dist directory inside the tarball. We don't+-- use the standard 'dist' location so unless we move this dist dir to the+-- right place then we'll miss the shipped pre-procssed files. This hacky+-- approach to shipped pre-procssed files ought to be replaced by a proper+-- system, though we'll still need to keep this hack for older packages.+--+moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout+                                -> FilePath -> PackageId -> DistDirParams+                                -> IO ()+moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}+                                parentdir pkgid dparams = do+    distDirExists <- doesDirectoryExist tarballDistDir+    when distDirExists $ do+      debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"+                                   ++ targetDistDir ++ "'"+      --TODO: [nice to have] or perhaps better to copy, and use a file monitor+      renameDirectory tarballDistDir targetDistDir+  where+    tarballDistDir = parentdir </> prettyShow pkgid </> "dist"+    targetDistDir  = distBuildDirectory dparams+++buildAndInstallUnpackedPackage :: Verbosity+                               -> DistDirLayout+                               -> StoreDirLayout+                               -> BuildTimeSettings -> Lock -> Lock+                               -> ElaboratedSharedConfig+                               -> ElaboratedInstallPlan+                               -> ElaboratedReadyPackage+                               -> FilePath -> FilePath+                               -> IO BuildResult+buildAndInstallUnpackedPackage verbosity+                               distDirLayout@DistDirLayout{distTempDirectory}+                               storeDirLayout@StoreDirLayout {+                                 storePackageDBStack+                               }+                               BuildTimeSettings {+                                 buildSettingNumJobs,+                                 buildSettingLogFile+                               }+                               registerLock cacheLock+                               pkgshared@ElaboratedSharedConfig {+                                 pkgConfigPlatform      = platform,+                                 pkgConfigCompiler      = compiler,+                                 pkgConfigCompilerProgs = progdb+                               }+                               plan rpkg@(ReadyPackage pkg)+                               srcdir builddir = do++    createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)+    initLogFile++    --TODO: [code cleanup] deal consistently with talking to older+    --      Setup.hs versions, much like we do for ghc, with a proper+    --      options type and rendering step which will also let us+    --      call directly into the lib, rather than always going via+    --      the lib's command line interface, which would also allow+    --      passing data like installed packages, compiler, and+    --      program db for a quicker configure.++    --TODO: [required feature] docs and tests+    --TODO: [required feature] sudo re-exec++    -- Configure phase+    noticeProgress ProgressStarting++    annotateFailure mlogFile ConfigureFailed $+      setup' configureCommand configureFlags configureArgs++    -- Build phase+    noticeProgress ProgressBuilding++    annotateFailure mlogFile BuildFailed $+      setup buildCommand buildFlags++    -- Haddock phase+    whenHaddock $ do+      noticeProgress ProgressHaddock+      annotateFailureNoLog HaddocksFailed $+        setup haddockCommand haddockFlags++    -- Install phase+    noticeProgress ProgressInstalling+    annotateFailure mlogFile InstallFailed $ do++      let copyPkgFiles tmpDir = do+            let tmpDirNormalised = normalise tmpDir+            setup Cabal.copyCommand (copyFlags tmpDirNormalised)+            -- Note that the copy command has put the files into+            -- @$tmpDir/$prefix@ so we need to return this dir so+            -- the store knows which dir will be the final store entry.+            let prefix   = normalise $+                           dropDrive (InstallDirs.prefix (elabInstallDirs pkg))+                entryDir = tmpDirNormalised </> prefix++            -- if there weren't anything to build, it might be that directory is not created+            -- the @setup Cabal.copyCommand@ above might do nothing.+            -- https://github.com/haskell/cabal/issues/4130+            createDirectoryIfMissingVerbose verbosity True entryDir++            LBS.writeFile+              (entryDir </> "cabal-hash.txt")+              (renderPackageHashInputs (packageHashInputs pkgshared pkg))++            -- Ensure that there are no files in `tmpDir`, that are+            -- not in `entryDir`. While this breaks the+            -- prefix-relocatable property of the libraries, it is+            -- necessary on macOS to stay under the load command limit+            -- of the macOS mach-o linker. See also+            -- @PackageHash.hashedInstalledPackageIdVeryShort@.+            --+            -- We also normalise paths to ensure that there are no+            -- different representations for the same path. Like / and+            -- \\ on windows under msys.+            otherFiles <- filter (not . isPrefixOf entryDir) <$>+                          listFilesRecursive tmpDirNormalised+            -- Here's where we could keep track of the installed files+            -- ourselves if we wanted to by making a manifest of the+            -- files in the tmp dir.+            return (entryDir, otherFiles)+            where+              listFilesRecursive :: FilePath -> IO [FilePath]+              listFilesRecursive path = do+                files <- fmap (path </>) <$> (listDirectory path)+                allFiles <- for files $ \file -> do+                  isDir <- doesDirectoryExist file+                  if isDir+                    then listFilesRecursive file+                    else return [file]+                return (concat allFiles)++          registerPkg+            | not (elabRequiresRegistration pkg) =+              debug verbosity $+                "registerPkg: elab does NOT require registration for "+                ++ prettyShow uid+            | otherwise = do+            -- We register ourselves rather than via Setup.hs. We need to+            -- grab and modify the InstalledPackageInfo. We decide what+            -- the installed package id is, not the build system.+            ipkg0 <- generateInstalledPackageInfo+            let ipkg = ipkg0 { Installed.installedUnitId = uid }+            assert (   elabRegisterPackageDBStack pkg+                    == storePackageDBStack compid) (return ())+            criticalSection registerLock $+              Cabal.registerPackage+                verbosity compiler progdb+                (storePackageDBStack compid) ipkg+                Cabal.defaultRegisterOptions {+                  Cabal.registerMultiInstance      = True,+                  Cabal.registerSuppressFilesCheck = True+                }+++      -- Actual installation+      void $ newStoreEntry verbosity storeDirLayout+                           compid uid+                           copyPkgFiles registerPkg++    --TODO: [nice to have] we currently rely on Setup.hs copy to do the right+    -- thing. Although we do copy into an image dir and do the move into the+    -- final location ourselves, perhaps we ought to do some sanity checks on+    -- the image dir first.++    -- TODO: [required eventually] note that for nix-style+    -- installations it is not necessary to do the+    -- 'withWin32SelfUpgrade' dance, but it would be necessary for a+    -- shared bin dir.++    --TODO: [required feature] docs and test phases+    let docsResult  = DocsNotTried+        testsResult = TestsNotTried++    noticeProgress ProgressCompleted++    return BuildResult {+       buildResultDocs    = docsResult,+       buildResultTests   = testsResult,+       buildResultLogFile = mlogFile+    }++  where+    pkgid  = packageId rpkg+    uid    = installedUnitId rpkg+    compid = compilerId compiler++    dispname = case elabPkgOrComp pkg of+        ElabPackage _ -> prettyShow pkgid+            ++ " (all, legacy fallback)"+        ElabComponent comp -> prettyShow pkgid+            ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")"++    noticeProgress phase = when isParallelBuild $+        progressMessage verbosity phase dispname++    isParallelBuild = buildSettingNumJobs >= 2++    whenHaddock action+      | hasValidHaddockTargets pkg = action+      | otherwise                  = return ()++    configureCommand = Cabal.configureCommand defaultProgramDb+    configureFlags v = flip filterConfigureFlags v $+                       setupHsConfigureFlags rpkg pkgshared+                                             verbosity builddir+    configureArgs _  = setupHsConfigureArgs pkg++    buildCommand     = Cabal.buildCommand defaultProgramDb+    buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir++    haddockCommand   = Cabal.haddockCommand+    haddockFlags _   = setupHsHaddockFlags pkg pkgshared+                                           verbosity builddir++    generateInstalledPackageInfo :: IO InstalledPackageInfo+    generateInstalledPackageInfo =+      withTempInstalledPackageInfoFile+        verbosity distTempDirectory $ \pkgConfDest -> do+        let registerFlags _ = setupHsRegisterFlags+                                pkg pkgshared+                                verbosity builddir+                                pkgConfDest+        setup Cabal.registerCommand registerFlags++    copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity+                                           builddir destdir++    scriptOptions = setupHsScriptOptions rpkg plan pkgshared+                                         distDirLayout srcdir builddir+                                         isParallelBuild cacheLock++    setup :: CommandUI flags -> (Version -> flags) -> IO ()+    setup cmd flags = setup' cmd flags (const [])++    setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String])+           -> IO ()+    setup' cmd flags args =+      withLogging $ \mLogFileHandle ->+        setupWrapper+          verbosity+          scriptOptions+            { useLoggingHandle     = mLogFileHandle+            , useExtraEnvOverrides = dataDirsEnvironmentForPlan+                                     distDirLayout plan }+          (Just (elabPkgDescription pkg))+          cmd flags args++    mlogFile :: Maybe FilePath+    mlogFile =+      case buildSettingLogFile of+        Nothing        -> Nothing+        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)++    initLogFile =+      case mlogFile of+        Nothing      -> return ()+        Just logFile -> do+          createDirectoryIfMissing True (takeDirectory logFile)+          exists <- doesFileExist logFile+          when exists $ removeFile logFile++    withLogging action =+      case mlogFile of+        Nothing      -> action Nothing+        Just logFile -> withFile logFile AppendMode (action . Just)+++hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool+hasValidHaddockTargets ElaboratedConfiguredPackage{..}+  | not elabBuildHaddocks = False+  | otherwise             = any componentHasHaddocks components+  where+    components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets+              ++ maybeToList elabReplTarget ++ elabHaddockTargets++    componentHasHaddocks :: ComponentTarget -> Bool+    componentHasHaddocks (ComponentTarget name _) =+      case name of+        CLibName LMainLibName    ->                           hasHaddocks+        CLibName (LSubLibName _) -> elabHaddockInternal    && hasHaddocks+        CFLibName              _ -> elabHaddockForeignLibs && hasHaddocks+        CExeName               _ -> elabHaddockExecutables && hasHaddocks+        CTestName              _ -> elabHaddockTestSuites  && hasHaddocks+        CBenchName             _ -> elabHaddockBenchmarks  && hasHaddocks+      where+        hasHaddocks = not (null (elabPkgDescription ^. componentModules name))+++buildInplaceUnpackedPackage :: Verbosity+                            -> DistDirLayout+                            -> BuildTimeSettings -> Lock -> Lock+                            -> ElaboratedSharedConfig+                            -> ElaboratedInstallPlan+                            -> ElaboratedReadyPackage+                            -> BuildStatusRebuild+                            -> FilePath -> FilePath+                            -> IO BuildResult+buildInplaceUnpackedPackage verbosity+                            distDirLayout@DistDirLayout {+                              distTempDirectory,+                              distPackageCacheDirectory,+                              distDirectory+                            }+                            BuildTimeSettings{buildSettingNumJobs}+                            registerLock cacheLock+                            pkgshared@ElaboratedSharedConfig {+                              pkgConfigCompiler      = compiler,+                              pkgConfigCompilerProgs = progdb+                            }+                            plan+                            rpkg@(ReadyPackage pkg)+                            buildStatus+                            srcdir builddir = do++        --TODO: [code cleanup] there is duplication between the+        --      distdirlayout and the builddir here builddir is not+        --      enough, we also need the per-package cachedir+        createDirectoryIfMissingVerbose verbosity True builddir+        createDirectoryIfMissingVerbose verbosity True+          (distPackageCacheDirectory dparams)++        -- Configure phase+        --+        whenReConfigure $ do+          annotateFailureNoLog ConfigureFailed $+            setup configureCommand configureFlags configureArgs+          invalidatePackageRegFileMonitor packageFileMonitor+          updatePackageConfigFileMonitor packageFileMonitor srcdir pkg++        -- Build phase+        --+        let docsResult  = DocsNotTried+            testsResult = TestsNotTried++            buildResult :: BuildResultMisc+            buildResult = (docsResult, testsResult)++        whenRebuild $ do+          timestamp <- beginUpdateFileMonitor+          annotateFailureNoLog BuildFailed $+            setup buildCommand buildFlags buildArgs++          let listSimple =+                execRebuild srcdir (needElaboratedConfiguredPackage pkg)+              listSdist =+                fmap (map monitorFileHashed) $+                    allPackageSourceFiles verbosity srcdir+              ifNullThen m m' = do xs <- m+                                   if null xs then m' else return xs+          monitors <- case PD.buildType (elabPkgDescription pkg) of+            Simple -> listSimple+            -- If a Custom setup was used, AND the Cabal is recent+            -- enough to have sdist --list-sources, use that to+            -- determine the files that we need to track.  This can+            -- cause unnecessary rebuilding (for example, if README+            -- is edited, we will try to rebuild) but there isn't+            -- a more accurate Custom interface we can use to get+            -- this info.  We prefer not to use listSimple here+            -- as it can miss extra source files that are considered+            -- by the Custom setup.+            _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17]+              -- However, sometimes sdist --list-sources will fail+              -- and return an empty list.  In that case, fall+              -- back on the (inaccurate) simple tracking.+              -> listSdist `ifNullThen` listSimple+              | otherwise+              -> listSimple++          let dep_monitors = map monitorFileHashed+                           $ elabInplaceDependencyBuildCacheFiles+                                distDirLayout pkgshared plan pkg+          updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp+                                        pkg buildStatus+                                        (monitors ++ dep_monitors) buildResult++        -- PURPOSELY omitted: no copy!++        whenReRegister $ annotateFailureNoLog InstallFailed $ do+          -- Register locally+          mipkg <- if elabRequiresRegistration pkg+            then do+                ipkg0 <- generateInstalledPackageInfo+                -- We register ourselves rather than via Setup.hs. We need to+                -- grab and modify the InstalledPackageInfo. We decide what+                -- the installed package id is, not the build system.+                let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }+                criticalSection registerLock $+                    Cabal.registerPackage verbosity compiler progdb+                                          (elabRegisterPackageDBStack pkg)+                                          ipkg Cabal.defaultRegisterOptions+                return (Just ipkg)++           else return Nothing++          updatePackageRegFileMonitor packageFileMonitor srcdir mipkg++        whenTest $ do+          annotateFailureNoLog TestsFailed $+            setup testCommand testFlags testArgs++        whenBench $+          annotateFailureNoLog BenchFailed $+            setup benchCommand benchFlags benchArgs++        -- Repl phase+        --+        whenRepl $+          annotateFailureNoLog ReplFailed $+          setupInteractive replCommand replFlags replArgs++        -- Haddock phase+        whenHaddock $+          annotateFailureNoLog HaddocksFailed $ do+            setup haddockCommand haddockFlags haddockArgs+            let haddockTarget = elabHaddockForHackage pkg+            when (haddockTarget == Cabal.ForHackage) $ do+              let dest = distDirectory </> name <.> "tar.gz"+                  name = haddockDirName haddockTarget (elabPkgDescription pkg)+                  docDir = distBuildDirectory distDirLayout dparams+                           </> "doc" </> "html"+              Tar.createTarGzFile dest docDir name+              notice verbosity $ "Documentation tarball created: " ++ dest++        return BuildResult {+          buildResultDocs    = docsResult,+          buildResultTests   = testsResult,+          buildResultLogFile = Nothing+        }++  where+    ipkgid  = installedUnitId pkg+    dparams = elabDistDirParams pkgshared pkg++    isParallelBuild = buildSettingNumJobs >= 2++    packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams++    whenReConfigure action = case buildStatus of+      BuildStatusConfigure _ -> action+      _                      -> return ()++    whenRebuild action+      | null (elabBuildTargets pkg)+      -- NB: we have to build the test/bench suite!+      , null (elabTestTargets pkg)+      , null (elabBenchTargets pkg) = return ()+      | otherwise                   = action++    whenTest action+      | null (elabTestTargets pkg) = return ()+      | otherwise                  = action++    whenBench action+      | null (elabBenchTargets pkg) = return ()+      | otherwise                   = action++    whenRepl action+      | isNothing (elabReplTarget pkg) = return ()+      | otherwise                     = action++    whenHaddock action+      | hasValidHaddockTargets pkg = action+      | otherwise                  = return ()++    whenReRegister  action+      = case buildStatus of+          -- We registered the package already+          BuildStatusBuild (Just _) _     ->+            info verbosity "whenReRegister: previously registered"+          -- There is nothing to register+          _ | null (elabBuildTargets pkg) ->+              info verbosity "whenReRegister: nothing to register"+            | otherwise                   -> action++    configureCommand = Cabal.configureCommand defaultProgramDb+    configureFlags v = flip filterConfigureFlags v $+                       setupHsConfigureFlags rpkg pkgshared+                                             verbosity builddir+    configureArgs _  = setupHsConfigureArgs pkg++    buildCommand     = Cabal.buildCommand defaultProgramDb+    buildFlags   _   = setupHsBuildFlags pkg pkgshared+                                         verbosity builddir+    buildArgs     _  = setupHsBuildArgs  pkg++    testCommand      = Cabal.testCommand -- defaultProgramDb+    testFlags      v = flip filterTestFlags v $+                       setupHsTestFlags pkg pkgshared+                                         verbosity builddir+    testArgs      _  = setupHsTestArgs  pkg++    benchCommand     = Cabal.benchmarkCommand+    benchFlags    _  = setupHsBenchFlags pkg pkgshared+                                          verbosity builddir+    benchArgs     _  = setupHsBenchArgs  pkg++    replCommand      = Cabal.replCommand defaultProgramDb+    replFlags _      = setupHsReplFlags pkg pkgshared+                                        verbosity builddir+    replArgs _       = setupHsReplArgs  pkg++    haddockCommand   = Cabal.haddockCommand+    haddockFlags v   = flip filterHaddockFlags v $+                       setupHsHaddockFlags pkg pkgshared+                                           verbosity builddir+    haddockArgs    v = flip filterHaddockArgs v $+                       setupHsHaddockArgs pkg++    scriptOptions    = setupHsScriptOptions rpkg plan pkgshared+                                            distDirLayout srcdir builddir+                                            isParallelBuild cacheLock++    setupInteractive :: CommandUI flags+                     -> (Version -> flags) -> (Version -> [String]) -> IO ()+    setupInteractive cmd flags args =+      setupWrapper verbosity+                   scriptOptions { isInteractive = True }+                   (Just (elabPkgDescription pkg))+                   cmd flags args++    setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])+          -> IO ()+    setup cmd flags args =+      setupWrapper verbosity+                   scriptOptions+                   (Just (elabPkgDescription pkg))+                   cmd flags args++    generateInstalledPackageInfo :: IO InstalledPackageInfo+    generateInstalledPackageInfo =+      withTempInstalledPackageInfoFile+        verbosity distTempDirectory $ \pkgConfDest -> do+        let registerFlags _ = setupHsRegisterFlags+                                pkg pkgshared+                                verbosity builddir+                                pkgConfDest+        setup Cabal.registerCommand registerFlags (const [])++withTempInstalledPackageInfoFile :: Verbosity -> FilePath+                                  -> (FilePath -> IO ())+                                  -> IO InstalledPackageInfo+withTempInstalledPackageInfoFile verbosity tempdir action =+    withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do+      -- make absolute since @action@ will often change directory+      abs_dir <- canonicalizePath dir++      let pkgConfDest = abs_dir </> "pkgConf"+      action pkgConfDest++      readPkgConf "." pkgConfDest+  where+    pkgConfParseFailed :: String -> IO a+    pkgConfParseFailed perror =+      die' verbosity $+      "Couldn't parse the output of 'setup register --gen-pkg-config':"+      ++ show perror++    readPkgConf pkgConfDir pkgConfFile = do+      pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)+      (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of+        Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors+        Right (warns, ipkg) -> return (warns, ipkg)++      unless (null warns) $+        warn verbosity $ unlines warns++      return ipkg+++------------------------------------------------------------------------------+-- * Utilities+------------------------------------------------------------------------------++annotateFailureNoLog :: (SomeException -> BuildFailureReason)+                     -> IO a -> IO a+annotateFailureNoLog annotate action =+  annotateFailure Nothing annotate action++annotateFailure :: Maybe FilePath+                -> (SomeException -> BuildFailureReason)+                -> IO a -> IO a+annotateFailure mlogFile annotate action =+  action `catches`+    -- It's not just IOException and ExitCode we have to deal with, there's+    -- lots, including exceptions from the hackage-security and tar packages.+    -- So we take the strategy of catching everything except async exceptions.+    [+#if MIN_VERSION_base(4,7,0)+      Handler $ \async -> throwIO (async :: SomeAsyncException)+#else+      Handler $ \async -> throwIO (async :: AsyncException)+#endif+    , Handler $ \other -> handler (other :: SomeException)+    ]+  where+    handler :: Exception e => e -> IO a+    handler = throwIO . BuildFailure mlogFile . annotate . toException
+ src/Distribution/Client/ProjectBuilding/Types.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Types for the "Distribution.Client.ProjectBuilding"+--+-- Moved out to avoid module cycles.+--+module Distribution.Client.ProjectBuilding.Types (+    -- * Pre-build status+    BuildStatusMap,+    BuildStatus(..),+    buildStatusRequiresBuild,+    buildStatusToString,+    BuildStatusRebuild(..),+    BuildReason(..),+    MonitorChangedReason(..),++    -- * Build outcomes+    BuildOutcomes,+    BuildOutcome,+    BuildResult(..),+    BuildFailure(..),+    BuildFailureReason(..),+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Types          (DocsResult, TestsResult)+import Distribution.Client.FileMonitor    (MonitorChangedReason(..))++import Distribution.Package               (UnitId, PackageId)+import Distribution.InstalledPackageInfo  (InstalledPackageInfo)+import Distribution.Simple.LocalBuildInfo (ComponentName)+++------------------------------------------------------------------------------+-- Pre-build status: result of the dry run+--++-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.+--+-- This is used as the result of the dry-run of building an install plan.+--+type BuildStatusMap = Map UnitId BuildStatus++-- | The build status for an individual package is the state that the+-- package is in /prior/ to initiating a (re)build.+--+-- This should not be confused with a 'BuildResult' which is the result+-- /after/ successfully building a package.+--+-- It serves two purposes:+--+--  * For dry-run output, it lets us explain to the user if and why a package+--    is going to be (re)built.+--+--  * It tell us what step to start or resume building from, and carries+--    enough information for us to be able to do so.+--+data BuildStatus =++     -- | The package is in the 'InstallPlan.PreExisting' state, so does not+     --   need building.+     BuildStatusPreExisting++     -- | The package is in the 'InstallPlan.Installed' state, so does not+     --   need building.+   | BuildStatusInstalled++     -- | The package has not been downloaded yet, so it will have to be+     --   downloaded, unpacked and built.+   | BuildStatusDownload++     -- | The package has not been unpacked yet, so it will have to be+     --   unpacked and built.+   | BuildStatusUnpack FilePath++     -- | The package exists in a local dir already, and just needs building+     --   or rebuilding. So this can only happen for 'BuildInplaceOnly' style+     --   packages.+   | BuildStatusRebuild FilePath BuildStatusRebuild++     -- | The package exists in a local dir already, and is fully up to date.+     --   So this package can be put into the 'InstallPlan.Installed' state+     --   and it does not need to be built.+   | BuildStatusUpToDate BuildResult+++-- | Which 'BuildStatus' values indicate we'll have to do some build work of+-- some sort. In particular we use this as part of checking if any of a+-- package's deps have changed.+--+buildStatusRequiresBuild :: BuildStatus -> Bool+buildStatusRequiresBuild BuildStatusPreExisting = False+buildStatusRequiresBuild BuildStatusInstalled   = False+buildStatusRequiresBuild BuildStatusUpToDate {} = False+buildStatusRequiresBuild _                      = True++-- | This is primarily here for debugging. It's not actually used anywhere.+--+buildStatusToString :: BuildStatus -> String+buildStatusToString BuildStatusPreExisting    = "BuildStatusPreExisting"+buildStatusToString BuildStatusInstalled      = "BuildStatusInstalled"+buildStatusToString BuildStatusDownload       = "BuildStatusDownload"+buildStatusToString (BuildStatusUnpack fp)    = "BuildStatusUnpack " ++ show fp+buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp+buildStatusToString (BuildStatusUpToDate _)   = "BuildStatusUpToDate"+++-- | For a package that is going to be built or rebuilt, the state it's in now.+--+-- So again, this tells us why a package needs to be rebuilt and what build+-- phases need to be run. The 'MonitorChangedReason' gives us details like+-- which file changed, which is mainly for high verbosity debug output.+--+data BuildStatusRebuild =++     -- | The package configuration changed, so the configure and build phases+     --   needs to be (re)run.+     BuildStatusConfigure (MonitorChangedReason ())++     -- | The configuration has not changed but the build phase needs to be+     -- rerun. We record the reason the (re)build is needed.+     --+     -- The optional registration info here tells us if we've registered the+     -- package already, or if we still need to do that after building.+     -- @Just Nothing@ indicates that we know that no registration is+     -- necessary (e.g., executable.)+     --+   | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason++data BuildReason =+     -- | The dependencies of this package have been (re)built so the build+     -- phase needs to be rerun.+     --+     BuildReasonDepsRebuilt++     -- | Changes in files within the package (or first run or corrupt cache)+   | BuildReasonFilesChanged (MonitorChangedReason ())++     -- | An important special case is that no files have changed but the+     -- set of components the /user asked to build/ has changed. We track the+     -- set of components /we have built/, which of course only grows (until+     -- some other change resets it).+     --+     -- The @Set 'ComponentName'@ is the set of components we have built+     -- previously. When we update the monitor we take the union of the ones+     -- we have built previously with the ones the user has asked for this+     -- time and save those. See 'updatePackageBuildFileMonitor'.+     --+   | BuildReasonExtraTargets (Set ComponentName)++     -- | Although we're not going to build any additional targets as a whole,+     -- we're going to build some part of a component or run a repl or any+     -- other action that does not result in additional persistent artifacts.+     --+   | BuildReasonEphemeralTargets+++------------------------------------------------------------------------------+-- Build outcomes: result of the build+--++-- | A summary of the outcome for building a whole set of packages.+--+type BuildOutcomes = Map UnitId BuildOutcome++-- | A summary of the outcome for building a single package: either success+-- or failure.+--+type BuildOutcome  = Either BuildFailure BuildResult++-- | Information arising from successfully building a single package.+--+data BuildResult = BuildResult {+       buildResultDocs    :: DocsResult,+       buildResultTests   :: TestsResult,+       buildResultLogFile :: Maybe FilePath+     }+  deriving Show++-- | Information arising from the failure to build a single package.+--+data BuildFailure = BuildFailure {+       buildFailureLogFile :: Maybe FilePath,+       buildFailureReason  :: BuildFailureReason+     }+  deriving (Show, Typeable)++instance Exception BuildFailure++-- | Detail on the reason that a package failed to build.+--+data BuildFailureReason = DependentFailed PackageId+                        | DownloadFailed  SomeException+                        | UnpackFailed    SomeException+                        | ConfigureFailed SomeException+                        | BuildFailed     SomeException+                        | ReplFailed      SomeException+                        | HaddocksFailed  SomeException+                        | TestsFailed     SomeException+                        | BenchFailed     SomeException+                        | InstallFailed   SomeException+  deriving Show
+ src/Distribution/Client/ProjectConfig.hs view
@@ -0,0 +1,1472 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE RecordWildCards    #-}++-- | Handling project configuration.+--+module Distribution.Client.ProjectConfig (++    -- * Types for project config+    ProjectConfig(..),+    ProjectConfigBuildOnly(..),+    ProjectConfigShared(..),+    ProjectConfigProvenance(..),+    PackageConfig(..),+    MapLast(..),+    MapMappend(..),++    -- * Project root+    findProjectRoot,+    ProjectRoot(..),+    BadProjectRoot(..),++    -- * Project config files+    readProjectConfig,+    readGlobalConfig,+    readProjectLocalFreezeConfig,+    showProjectConfig,+    withProjectOrGlobalConfig,+    writeProjectLocalExtraConfig,+    writeProjectLocalFreezeConfig,+    writeProjectConfigFile,+    commandLineFlagsToProjectConfig,++    -- * Packages within projects+    ProjectPackageLocation(..),+    BadPackageLocations(..),+    BadPackageLocation(..),+    BadPackageLocationMatch(..),+    findProjectPackages,+    fetchAndReadSourcePackages,++    -- * Resolving configuration+    lookupLocalPackageConfig,+    projectConfigWithBuilderRepoContext,+    projectConfigWithSolverRepoContext,+    SolverSettings(..),+    resolveSolverSettings,+    BuildTimeSettings(..),+    resolveBuildTimeSettings,++    -- * Checking configuration+    checkBadPerPackageCompilerPaths,+    BadPerPackageCompilerPaths(..)+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.ProjectConfig.Types+import Distribution.Client.ProjectConfig.Legacy+import Distribution.Client.RebuildMonad+import Distribution.Client.Glob+         ( isTrivialFilePathGlob )+import Distribution.Client.VCS+         ( validateSourceRepos, SourceRepoProblem(..)+         , VCS(..), knownVCSs, configureVCS, syncSourceRepos )++import Distribution.Client.Types+import Distribution.Client.DistDirLayout+         ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..) )+import Distribution.Client.GlobalFlags+         ( RepoContext(..), withRepoContext' )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Config+         ( loadConfig, getConfigFilePath )+import Distribution.Client.HttpUtils+         ( HttpTransport, configureTransport, transportCheckHttps+         , downloadURI )+import Distribution.Client.Utils.Parsec (renderParseError)++import Distribution.Solver.Types.SourcePackage+import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.PackageConstraint+         ( PackageProperty(..) )++import Distribution.Package+         ( PackageName, PackageId, UnitId, packageId )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint(..) )+import Distribution.System+         ( Platform )+import Distribution.Types.GenericPackageDescription+         ( GenericPackageDescription )+import Distribution.PackageDescription.Parsec+         ( parseGenericPackageDescription )+import Distribution.Fields+         ( runParseResult, PError, PWarning, showPWarning)+import Distribution.Types.SourceRepo+         ( RepoType(..) )+import Distribution.Client.Types.SourceRepo+         ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut )+import Distribution.Simple.Compiler+         ( Compiler, compilerInfo )+import Distribution.Simple.Program+         ( ConfiguredProgram(..) )+import Distribution.Simple.Setup+         ( Flag(Flag), toFlag, flagToMaybe, flagToList+         , fromFlag, fromFlagOrDefault )+import Distribution.Client.Setup+         ( defaultSolver, defaultMaxBackjumps )+import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , toPathTemplate, substPathTemplate, initialPathTemplateEnv )+import Distribution.Simple.Utils+         ( die', warn, notice, info, createDirectoryIfMissingVerbose, rawSystemIOWithEnv )+import Distribution.Client.Utils+         ( determineNumJobs )+import Distribution.Utils.NubList+         ( fromNubList )+import Distribution.Verbosity+         ( modifyVerbosity, verbose )+import Distribution.Version+         ( Version )+import qualified Distribution.Deprecated.ParseUtils as OldParser+         ( ParseResult(..), locatedErrorMsg, showPWarning )+import Distribution.Client.SrcDist+         ( packageDirToSdist )++import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Distribution.Client.Tar as Tar+import qualified Distribution.Client.GZipUtils as GZipUtils++import Control.Monad.Trans (liftIO)+import qualified Data.ByteString       as BS+import qualified Data.ByteString.Lazy  as LBS+import qualified Data.Map as Map+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as Set+import qualified Data.Hashable as Hashable+import Numeric (showHex)++import System.FilePath hiding (combine)+import System.IO+         ( withBinaryFile, IOMode(ReadMode) )+import System.Directory+import Network.URI+         ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString )+++----------------------------------------+-- Resolving configuration to settings+--++-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific+-- 'PackageName'. This returns the configuration that applies to all local+-- packages plus any package-specific configuration for this package.+--+lookupLocalPackageConfig+  :: (Semigroup a, Monoid a)+  => (PackageConfig -> a) -> ProjectConfig -> PackageName+  -> a+lookupLocalPackageConfig field ProjectConfig {+                           projectConfigLocalPackages,+                           projectConfigSpecificPackage+                         } pkgname =+    field projectConfigLocalPackages+ <> maybe mempty field+          (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))+++-- | Use a 'RepoContext' based on the 'BuildTimeSettings'.+--+projectConfigWithBuilderRepoContext :: Verbosity+                                    -> BuildTimeSettings+                                    -> (RepoContext -> IO a) -> IO a+projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} =+    withRepoContext'+      verbosity+      buildSettingRemoteRepos+      buildSettingLocalNoIndexRepos+      buildSettingCacheDir+      buildSettingHttpTransport+      (Just buildSettingIgnoreExpiry)+      buildSettingProgPathExtra+++-- | Use a 'RepoContext', but only for the solver. The solver does not use the+-- full facilities of the 'RepoContext' so we can get away with making one+-- that doesn't have an http transport. And that avoids having to have access+-- to the 'BuildTimeSettings'+--+projectConfigWithSolverRepoContext+  :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly+  -> (RepoContext -> IO a)+  -> IO a+projectConfigWithSolverRepoContext verbosity+                                   ProjectConfigShared{..}+                                   ProjectConfigBuildOnly{..} =+    withRepoContext'+      verbosity+      (fromNubList projectConfigRemoteRepos)+      (fromNubList projectConfigLocalNoIndexRepos)+      (fromFlagOrDefault+                   (error+                    "projectConfigWithSolverRepoContext: projectConfigCacheDir")+                   projectConfigCacheDir)+      (flagToMaybe projectConfigHttpTransport)+      (flagToMaybe projectConfigIgnoreExpiry)+      (fromNubList projectConfigProgPathExtra)+++-- | Resolve the project configuration, with all its optional fields, into+-- 'SolverSettings' with no optional fields (by applying defaults).+--+resolveSolverSettings :: ProjectConfig -> SolverSettings+resolveSolverSettings ProjectConfig{+                        projectConfigShared,+                        projectConfigLocalPackages,+                        projectConfigSpecificPackage+                      } =+    SolverSettings {..}+  where+    --TODO: [required eventually] some of these settings need validation, e.g.+    -- the flag assignments need checking.+    solverSettingRemoteRepos       = fromNubList projectConfigRemoteRepos+    solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos+    solverSettingConstraints       = projectConfigConstraints+    solverSettingPreferences       = projectConfigPreferences+    solverSettingFlagAssignment    = packageConfigFlagAssignment projectConfigLocalPackages+    solverSettingFlagAssignments   = fmap packageConfigFlagAssignment+                                          (getMapMappend projectConfigSpecificPackage)+    solverSettingCabalVersion      = flagToMaybe projectConfigCabalVersion+    solverSettingSolver            = fromFlag projectConfigSolver+    solverSettingAllowOlder        = fromMaybe mempty projectConfigAllowOlder+    solverSettingAllowNewer        = fromMaybe mempty projectConfigAllowNewer+    solverSettingMaxBackjumps      = case fromFlag projectConfigMaxBackjumps of+                                       n | n < 0     -> Nothing+                                         | otherwise -> Just n+    solverSettingReorderGoals      = fromFlag projectConfigReorderGoals+    solverSettingCountConflicts    = fromFlag projectConfigCountConflicts+    solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts+    solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet+    solverSettingStrongFlags       = fromFlag projectConfigStrongFlags+    solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls+    solverSettingOnlyConstrained   = fromFlag projectConfigOnlyConstrained+    solverSettingIndexState        = flagToMaybe projectConfigIndexState+    solverSettingActiveRepos       = flagToMaybe projectConfigActiveRepos+    solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals+  --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs+  --solverSettingReinstall         = fromFlag projectConfigReinstall+  --solverSettingAvoidReinstalls   = fromFlag projectConfigAvoidReinstalls+  --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall+  --solverSettingUpgradeDeps       = fromFlag projectConfigUpgradeDeps++    ProjectConfigShared {..} = defaults <> projectConfigShared++    defaults = mempty {+       projectConfigSolver            = Flag defaultSolver,+       projectConfigAllowOlder        = Just (AllowOlder mempty),+       projectConfigAllowNewer        = Just (AllowNewer mempty),+       projectConfigMaxBackjumps      = Flag defaultMaxBackjumps,+       projectConfigReorderGoals      = Flag (ReorderGoals False),+       projectConfigCountConflicts    = Flag (CountConflicts True),+       projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True),+       projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False),+       projectConfigStrongFlags       = Flag (StrongFlags False),+       projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False),+       projectConfigOnlyConstrained   = Flag OnlyConstrainedNone,+       projectConfigIndependentGoals  = Flag (IndependentGoals False)+     --projectConfigShadowPkgs        = Flag False,+     --projectConfigReinstall         = Flag False,+     --projectConfigAvoidReinstalls   = Flag False,+     --projectConfigOverrideReinstall = Flag False,+     --projectConfigUpgradeDeps       = Flag False+    }+++-- | Resolve the project configuration, with all its optional fields, into+-- 'BuildTimeSettings' with no optional fields (by applying defaults).+--+resolveBuildTimeSettings :: Verbosity+                         -> CabalDirLayout+                         -> ProjectConfig+                         -> BuildTimeSettings+resolveBuildTimeSettings verbosity+                         CabalDirLayout {+                           cabalLogsDirectory+                         }+                         ProjectConfig {+                           projectConfigShared = ProjectConfigShared {+                             projectConfigRemoteRepos,+                             projectConfigLocalNoIndexRepos,+                             projectConfigProgPathExtra+                           },+                           projectConfigBuildOnly+                         } =+    BuildTimeSettings {..}+  where+    buildSettingDryRun        = fromFlag    projectConfigDryRun+    buildSettingOnlyDeps      = fromFlag    projectConfigOnlyDeps+    buildSettingOnlyDownload  = fromFlag    projectConfigOnlyDownload+    buildSettingSummaryFile   = fromNubList projectConfigSummaryFile+    --buildSettingLogFile       -- defined below, more complicated+    --buildSettingLogVerbosity  -- defined below, more complicated+    buildSettingBuildReports  = fromFlag    projectConfigBuildReports+    buildSettingSymlinkBinDir = flagToList  projectConfigSymlinkBinDir+    buildSettingOneShot       = fromFlag    projectConfigOneShot+    buildSettingNumJobs       = determineNumJobs projectConfigNumJobs+    buildSettingKeepGoing     = fromFlag    projectConfigKeepGoing+    buildSettingOfflineMode   = fromFlag    projectConfigOfflineMode+    buildSettingKeepTempFiles = fromFlag    projectConfigKeepTempFiles+    buildSettingRemoteRepos   = fromNubList projectConfigRemoteRepos+    buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos+    buildSettingCacheDir      = fromFlag    projectConfigCacheDir+    buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport+    buildSettingIgnoreExpiry  = fromFlag    projectConfigIgnoreExpiry+    buildSettingReportPlanningFailure+                              = fromFlag projectConfigReportPlanningFailure+    buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra++    ProjectConfigBuildOnly{..} = defaults+                              <> projectConfigBuildOnly++    defaults = mempty {+      projectConfigDryRun                = toFlag False,+      projectConfigOnlyDeps              = toFlag False,+      projectConfigOnlyDownload          = toFlag False,+      projectConfigBuildReports          = toFlag NoReports,+      projectConfigReportPlanningFailure = toFlag False,+      projectConfigKeepGoing             = toFlag False,+      projectConfigOneShot               = toFlag False,+      projectConfigOfflineMode           = toFlag False,+      projectConfigKeepTempFiles         = toFlag False,+      projectConfigIgnoreExpiry          = toFlag False+    }++    -- The logging logic: what log file to use and what verbosity.+    --+    -- If the user has specified --remote-build-reporting=detailed, use the+    -- default log file location. If the --build-log option is set, use the+    -- provided location. Otherwise don't use logging, unless building in+    -- parallel (in which case the default location is used).+    --+    buildSettingLogFile :: Maybe (Compiler -> Platform+                               -> PackageId -> UnitId -> FilePath)+    buildSettingLogFile+      | useDefaultTemplate = Just (substLogFileName defaultTemplate)+      | otherwise          = fmap  substLogFileName givenTemplate++    defaultTemplate = toPathTemplate $+                        cabalLogsDirectory </>+                        "$compiler" </> "$libname" <.> "log"+    givenTemplate   = flagToMaybe projectConfigLogFile++    useDefaultTemplate+      | buildSettingBuildReports == DetailedReports = True+      | isJust givenTemplate                        = False+      | isParallelBuild                             = True+      | otherwise                                   = False++    isParallelBuild = buildSettingNumJobs >= 2++    substLogFileName :: PathTemplate+                     -> Compiler -> Platform+                     -> PackageId -> UnitId -> FilePath+    substLogFileName template compiler platform pkgid uid =+        fromPathTemplate (substPathTemplate env template)+      where+        env = initialPathTemplateEnv+                pkgid uid (compilerInfo compiler) platform++    -- If the user has specified --remote-build-reporting=detailed or+    -- --build-log, use more verbose logging.+    --+    buildSettingLogVerbosity+      | overrideVerbosity = modifyVerbosity (max verbose) verbosity+      | otherwise         = verbosity++    overrideVerbosity+      | buildSettingBuildReports == DetailedReports = True+      | isJust givenTemplate                        = True+      | isParallelBuild                             = False+      | otherwise                                   = False+++---------------------------------------------+-- Reading and writing project config files+--++-- | Find the root of this project.+--+-- Searches for an explicit @cabal.project@ file, in the current directory or+-- parent directories. If no project file is found then the current dir is the+-- project root (and the project will use an implicit config).+--+findProjectRoot :: Maybe FilePath -- ^ starting directory, or current directory+                -> Maybe FilePath -- ^ @cabal.project@ file name override+                -> IO (Either BadProjectRoot ProjectRoot)+findProjectRoot _ (Just projectFile)+  | isAbsolute projectFile = do+    exists <- doesFileExist projectFile+    if exists+      then do projectFile' <- canonicalizePath projectFile+              let projectRoot = ProjectRootExplicit (takeDirectory projectFile')+                                                    (takeFileName projectFile')+              return (Right projectRoot)+      else return (Left (BadProjectRootExplicitFile projectFile))++findProjectRoot mstartdir mprojectFile = do+    startdir <- maybe getCurrentDirectory canonicalizePath mstartdir+    homedir  <- getHomeDirectory+    probe startdir homedir+  where+    projectFileName = fromMaybe "cabal.project" mprojectFile++    -- Search upwards. If we get to the users home dir or the filesystem root,+    -- then use the current dir+    probe startdir homedir = go startdir+      where+        go dir | isDrive dir || dir == homedir =+          case mprojectFile of+            Nothing   -> return (Right (ProjectRootImplicit startdir))+            Just file -> return (Left (BadProjectRootExplicitFile file))+        go dir = do+          exists <- doesFileExist (dir </> projectFileName)+          if exists+            then return (Right (ProjectRootExplicit dir projectFileName))+            else go (takeDirectory dir)++-- | Errors returned by 'findProjectRoot'.+--+data BadProjectRoot = BadProjectRootExplicitFile FilePath+#if MIN_VERSION_base(4,8,0)+  deriving (Show, Typeable)+#else+  deriving (Typeable)++instance Show BadProjectRoot where+  show = renderBadProjectRoot+#endif++instance Exception BadProjectRoot where+#if MIN_VERSION_base(4,8,0)+  displayException = renderBadProjectRoot+#endif++renderBadProjectRoot :: BadProjectRoot -> String+renderBadProjectRoot (BadProjectRootExplicitFile projectFile) =+    "The given project file '" ++ projectFile ++ "' does not exist."++withProjectOrGlobalConfig+    :: Verbosity                  -- ^ verbosity+    -> Flag Bool                  -- ^ whether to ignore local project+    -> Flag FilePath              -- ^ @--cabal-config@+    -> IO a                       -- ^ with project+    -> (ProjectConfig -> IO a)    -- ^ without projet+    -> IO a+withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do+    globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf+    without globalConfig+withProjectOrGlobalConfig verbosity _ignorePrj  gcf  with without =+    withProjectOrGlobalConfig' verbosity gcf with without++withProjectOrGlobalConfig'+    :: Verbosity+    -> Flag FilePath+    -> IO a+    -> (ProjectConfig -> IO a)+    -> IO a+withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do+  globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag++  let+    res' = catch with+      $ \case+        (BadPackageLocations prov locs)+          | prov == Set.singleton Implicit+          , let+            isGlobErr (BadLocGlobEmptyMatch _) = True+            isGlobErr _ = False+          , any isGlobErr locs ->+            without globalConfig+        err -> throwIO err++  catch res'+    $ \case+      (BadProjectRootExplicitFile "") -> without globalConfig+      err -> throwIO err++-- | Read all the config relevant for a project. This includes the project+-- file if any, plus other global config.+--+readProjectConfig :: Verbosity+                  -> Flag FilePath+                  -> DistDirLayout+                  -> Rebuild ProjectConfig+readProjectConfig verbosity configFileFlag distDirLayout = do+    global <- readGlobalConfig                verbosity configFileFlag+    local  <- readProjectLocalConfigOrDefault verbosity distDirLayout+    freeze <- readProjectLocalFreezeConfig    verbosity distDirLayout+    extra  <- readProjectLocalExtraConfig     verbosity distDirLayout+    return (global <> local <> freeze <> extra)+++-- | Reads an explicit @cabal.project@ file in the given project root dir,+-- or returns the default project config for an implicitly defined project.+--+readProjectLocalConfigOrDefault :: Verbosity+                                -> DistDirLayout+                                -> Rebuild ProjectConfig+readProjectLocalConfigOrDefault verbosity distDirLayout = do+  usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile+  if usesExplicitProjectRoot+    then do+      readProjectFile verbosity distDirLayout "" "project file"+    else do+      monitorFiles [monitorNonExistentFile projectFile]+      return defaultImplicitProjectConfig++  where+    projectFile = distProjectFile distDirLayout ""++    defaultImplicitProjectConfig :: ProjectConfig+    defaultImplicitProjectConfig =+      mempty {+        -- We expect a package in the current directory.+        projectPackages         = [ "./*.cabal" ],++        projectConfigProvenance = Set.singleton Implicit+      }++-- | Reads a @cabal.project.local@ file in the given project root dir,+-- or returns empty. This file gets written by @cabal configure@, or in+-- principle can be edited manually or by other tools.+--+readProjectLocalExtraConfig :: Verbosity -> DistDirLayout+                            -> Rebuild ProjectConfig+readProjectLocalExtraConfig verbosity distDirLayout =+    readProjectFile verbosity distDirLayout "local"+                             "project local configuration file"++-- | Reads a @cabal.project.freeze@ file in the given project root dir,+-- or returns empty. This file gets written by @cabal freeze@, or in+-- principle can be edited manually or by other tools.+--+readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout+                             -> Rebuild ProjectConfig+readProjectLocalFreezeConfig verbosity distDirLayout =+    readProjectFile verbosity distDirLayout "freeze"+                             "project freeze file"++-- | Reads a named config file in the given project root dir, or returns empty.+--+readProjectFile :: Verbosity+                -> DistDirLayout+                -> String+                -> String+                -> Rebuild ProjectConfig+readProjectFile verbosity DistDirLayout{distProjectFile}+                         extensionName extensionDescription = do+    exists <- liftIO $ doesFileExist extensionFile+    if exists+      then do monitorFiles [monitorFileHashed extensionFile]+              addProjectFileProvenance <$> liftIO readExtensionFile+      else do monitorFiles [monitorNonExistentFile extensionFile]+              return mempty+  where+    extensionFile = distProjectFile extensionName++    readExtensionFile =+          reportParseResult verbosity extensionDescription extensionFile+        . (parseProjectConfig extensionFile)+      =<< BS.readFile extensionFile++    addProjectFileProvenance config =+      config {+        projectConfigProvenance =+          Set.insert (Explicit extensionFile) (projectConfigProvenance config)+      }+++-- | Parse the 'ProjectConfig' format.+--+-- For the moment this is implemented in terms of parsers for legacy+-- configuration types, plus a conversion.+--+parseProjectConfig :: FilePath -> BS.ByteString -> OldParser.ParseResult ProjectConfig+parseProjectConfig source content =+    convertLegacyProjectConfig <$>+      (parseLegacyProjectConfig source content)+++-- | Render the 'ProjectConfig' format.+--+-- For the moment this is implemented in terms of a pretty printer for the+-- legacy configuration types, plus a conversion.+--+showProjectConfig :: ProjectConfig -> String+showProjectConfig =+    showLegacyProjectConfig . convertToLegacyProjectConfig+++-- | Write a @cabal.project.local@ file in the given project root dir.+--+writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO ()+writeProjectLocalExtraConfig DistDirLayout{distProjectFile} =+    writeProjectConfigFile (distProjectFile "local")+++-- | Write a @cabal.project.freeze@ file in the given project root dir.+--+writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO ()+writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} =+    writeProjectConfigFile (distProjectFile "freeze")+++-- | Write in the @cabal.project@ format to the given file.+--+writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()+writeProjectConfigFile file =+    writeFile file . showProjectConfig+++-- | Read the user's @~/.cabal/config@ file.+--+readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig+readGlobalConfig verbosity configFileFlag = do+    config     <- liftIO (loadConfig verbosity configFileFlag)+    configFile <- liftIO (getConfigFilePath configFileFlag)+    monitorFiles [monitorFileHashed configFile]+    return (convertLegacyGlobalConfig config)++reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult a -> IO a+reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do+    unless (null warnings) $+      let msg = unlines (map (OldParser.showPWarning filename) warnings)+       in warn verbosity msg+    return x+reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =+    let (line, msg) = OldParser.locatedErrorMsg err+     in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename+           ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+++---------------------------------------------+-- Finding packages in the project+--++-- | The location of a package as part of a project. Local file paths are+-- either absolute (if the user specified it as such) or they are relative+-- to the project root.+--+data ProjectPackageLocation =+     ProjectPackageLocalCabalFile FilePath+   | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file+   | ProjectPackageLocalTarball   FilePath+   | ProjectPackageRemoteTarball  URI+   | ProjectPackageRemoteRepo     SourceRepoList+   | ProjectPackageNamed          PackageVersionConstraint+  deriving Show+++-- | Exception thrown by 'findProjectPackages'.+--+data BadPackageLocations+   = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]+#if MIN_VERSION_base(4,8,0)+  deriving (Show, Typeable)+#else+  deriving (Typeable)++instance Show BadPackageLocations where+  show = renderBadPackageLocations+#endif++instance Exception BadPackageLocations where+#if MIN_VERSION_base(4,8,0)+  displayException = renderBadPackageLocations+#endif+--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc++data BadPackageLocation+   = BadPackageLocationFile    BadPackageLocationMatch+   | BadLocGlobEmptyMatch      String+   | BadLocGlobBadMatches      String [BadPackageLocationMatch]+   | BadLocUnexpectedUriScheme String+   | BadLocUnrecognisedUri     String+   | BadLocUnrecognised        String+  deriving Show++data BadPackageLocationMatch+   = BadLocUnexpectedFile      String+   | BadLocNonexistantFile     String+   | BadLocDirNoCabalFile      String+   | BadLocDirManyCabalFiles   String+  deriving Show++renderBadPackageLocations :: BadPackageLocations -> String+renderBadPackageLocations (BadPackageLocations provenance bpls)+      -- There is no provenance information,+      -- render standard bad package error information.+    | Set.null provenance = renderErrors renderBadPackageLocation++      -- The configuration is implicit, render bad package locations+      -- using possibly specialized error messages.+    | Set.singleton Implicit == provenance =+        renderErrors renderImplicitBadPackageLocation++      -- The configuration contains both implicit and explicit provenance.+      -- This should not occur, and a message is output to assist debugging.+    | Implicit `Set.member` provenance =+           "Warning: both implicit and explicit configuration is present."+        ++ renderExplicit++      -- The configuration was read from one or more explicit path(s),+      -- list the locations and render the bad package error information.+      -- The intent is to supersede this with the relevant location information+      -- per package error.+    | otherwise = renderExplicit+  where+    renderErrors f = unlines (map f bpls)++    renderExplicit =+           "When using configuration(s) from "+        ++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance))+        ++ ", the following errors occurred:\n"+        ++ renderErrors renderBadPackageLocation++    getExplicit (Explicit path) = Just path+    getExplicit Implicit        = Nothing++--TODO: [nice to have] keep track of the config file (and src loc) packages+-- were listed, to use in error messages++-- | Render bad package location error information for the implicit+-- @cabal.project@ configuration.+--+-- TODO: This is currently not fully realized, with only one of the implicit+-- cases handled. More cases should be added with informative help text+-- about the issues related specifically when having no project configuration+-- is present.+renderImplicitBadPackageLocation :: BadPackageLocation -> String+renderImplicitBadPackageLocation bpl = case bpl of+    BadLocGlobEmptyMatch pkglocstr ->+        "No cabal.project file or cabal file matching the default glob '"+     ++ pkglocstr ++ "' was found.\n"+     ++ "Please create a package description file <pkgname>.cabal "+     ++ "or a cabal.project file referencing the packages you "+     ++ "want to build."+    _ -> renderBadPackageLocation bpl++renderBadPackageLocation :: BadPackageLocation -> String+renderBadPackageLocation bpl = case bpl of+    BadPackageLocationFile badmatch ->+        renderBadPackageLocationMatch badmatch+    BadLocGlobEmptyMatch pkglocstr ->+        "The package location glob '" ++ pkglocstr+     ++ "' does not match any files or directories."+    BadLocGlobBadMatches pkglocstr failures ->+        "The package location glob '" ++ pkglocstr ++ "' does not match any "+     ++ "recognised forms of package. "+     ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures+    BadLocUnexpectedUriScheme pkglocstr ->+        "The package location URI '" ++ pkglocstr ++ "' does not use a "+     ++ "supported URI scheme. The supported URI schemes are http, https and "+     ++ "file."+    BadLocUnrecognisedUri pkglocstr ->+        "The package location URI '" ++ pkglocstr ++ "' does not appear to "+     ++ "be a valid absolute URI."+    BadLocUnrecognised pkglocstr ->+        "The package location syntax '" ++ pkglocstr ++ "' is not recognised."++renderBadPackageLocationMatch :: BadPackageLocationMatch -> String+renderBadPackageLocationMatch bplm = case bplm of+    BadLocUnexpectedFile pkglocstr ->+        "The package location '" ++ pkglocstr ++ "' is not recognised. The "+     ++ "supported file targets are .cabal files, .tar.gz tarballs or package "+     ++ "directories (i.e. directories containing a .cabal file)."+    BadLocNonexistantFile pkglocstr ->+        "The package location '" ++ pkglocstr ++ "' does not exist."+    BadLocDirNoCabalFile pkglocstr ->+        "The package directory '" ++ pkglocstr ++ "' does not contain any "+     ++ ".cabal file."+    BadLocDirManyCabalFiles pkglocstr ->+        "The package directory '" ++ pkglocstr ++ "' contains multiple "+     ++ ".cabal files (which is not currently supported)."++-- | Given the project config,+--+-- Throws 'BadPackageLocations'.+--+findProjectPackages :: DistDirLayout -> ProjectConfig+                    -> Rebuild [ProjectPackageLocation]+findProjectPackages DistDirLayout{distProjectRootDirectory}+                    ProjectConfig{..} = do++    requiredPkgs <- findPackageLocations True    projectPackages+    optionalPkgs <- findPackageLocations False   projectPackagesOptional+    let repoPkgs  = map ProjectPackageRemoteRepo projectPackagesRepo+        namedPkgs = map ProjectPackageNamed      projectPackagesNamed++    return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])+  where+    findPackageLocations required pkglocstr = do+      (problems, pkglocs) <-+        partitionEithers <$> traverse (findPackageLocation required) pkglocstr+      unless (null problems) $+        liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems+      return (concat pkglocs)+++    findPackageLocation :: Bool -> String+                        -> Rebuild (Either BadPackageLocation+                                          [ProjectPackageLocation])+    findPackageLocation _required@True pkglocstr =+      -- strategy: try first as a file:// or http(s):// URL.+      -- then as a file glob (usually encompassing single file)+      -- finally as a single file, for files that fail to parse as globs+                    checkIsUriPackage pkglocstr+      `mplusMaybeT` checkIsFileGlobPackage pkglocstr+      `mplusMaybeT` checkIsSingleFilePackage pkglocstr+      >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return+++    findPackageLocation _required@False pkglocstr = do+      -- just globs for optional case+      res <- checkIsFileGlobPackage pkglocstr+      case res of+        Nothing              -> return (Left (BadLocUnrecognised pkglocstr))+        Just (Left _)        -> return (Right []) -- it's optional+        Just (Right pkglocs) -> return (Right pkglocs)+++    checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage+      :: String -> Rebuild (Maybe (Either BadPackageLocation+                                         [ProjectPackageLocation]))+    checkIsUriPackage pkglocstr =+      case parseAbsoluteURI pkglocstr of+        Just uri@URI {+            uriScheme    = scheme,+            uriAuthority = Just URIAuth { uriRegName = host },+            uriPath      = path,+            uriQuery     = query,+            uriFragment  = frag+          }+          | recognisedScheme && not (null host) ->+            return (Just (Right [ProjectPackageRemoteTarball uri]))++          | scheme == "file:" && null host && null query && null frag ->+            checkIsSingleFilePackage path++          | not recognisedScheme && not (null host) ->+            return (Just (Left (BadLocUnexpectedUriScheme pkglocstr)))++          | recognisedScheme && null host ->+            return (Just (Left (BadLocUnrecognisedUri pkglocstr)))+          where+            recognisedScheme = scheme == "http:" || scheme == "https:"+                            || scheme == "file:"++        _ -> return Nothing+++    checkIsFileGlobPackage pkglocstr =+      case simpleParsec pkglocstr of+        Nothing   -> return Nothing+        Just glob -> liftM Just $ do+          matches <- matchFileGlob glob+          case matches of+            [] | isJust (isTrivialFilePathGlob glob)+               -> return (Left (BadPackageLocationFile+                                  (BadLocNonexistantFile pkglocstr)))++            [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))++            _  -> do+              (failures, pkglocs) <- partitionEithers <$>+                                     traverse checkFilePackageMatch matches+              return $! case (failures, pkglocs) of+                ([failure], []) | isJust (isTrivialFilePathGlob glob)+                        -> Left (BadPackageLocationFile failure)+                (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)+                _       -> Right pkglocs+++    checkIsSingleFilePackage pkglocstr = do+      let filename = distProjectRootDirectory </> pkglocstr+      isFile <- liftIO $ doesFileExist filename+      isDir  <- liftIO $ doesDirectoryExist filename+      if isFile || isDir+        then checkFilePackageMatch pkglocstr+         >>= either (return . Just . Left  . BadPackageLocationFile)+                    (return . Just . Right . (\x->[x]))+        else return Nothing+++    checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch+                                                       ProjectPackageLocation)+    checkFilePackageMatch pkglocstr = do+      -- The pkglocstr may be absolute or may be relative to the project root.+      -- Either way, </> does the right thing here. We return relative paths if+      -- they were relative in the first place.+      let abspath = distProjectRootDirectory </> pkglocstr+      isFile <- liftIO $ doesFileExist abspath+      isDir  <- liftIO $ doesDirectoryExist abspath+      parentDirExists <- case takeDirectory abspath of+                           []  -> return False+                           dir -> liftIO $ doesDirectoryExist dir+      case () of+        _ | isDir+         -> do matches <- matchFileGlob (globStarDotCabal pkglocstr)+               case matches of+                 [cabalFile]+                     -> return (Right (ProjectPackageLocalDirectory+                                         pkglocstr cabalFile))+                 []  -> return (Left (BadLocDirNoCabalFile pkglocstr))+                 _   -> return (Left (BadLocDirManyCabalFiles pkglocstr))++          | extensionIsTarGz pkglocstr+         -> return (Right (ProjectPackageLocalTarball pkglocstr))++          | takeExtension pkglocstr == ".cabal"+         -> return (Right (ProjectPackageLocalCabalFile pkglocstr))++          | isFile+         -> return (Left (BadLocUnexpectedFile pkglocstr))++          | parentDirExists+         -> return (Left (BadLocNonexistantFile pkglocstr))++          | otherwise+         -> return (Left (BadLocUnexpectedFile pkglocstr))+++    extensionIsTarGz f = takeExtension f                 == ".gz"+                      && takeExtension (dropExtension f) == ".tar"+++-- | A glob to find all the cabal files in a directory.+--+-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.+-- The directory part can be either absolute or relative.+--+globStarDotCabal :: FilePath -> FilePathGlob+globStarDotCabal dir =+    FilePathGlob+      (if isAbsolute dir then FilePathRoot root else FilePathRelative)+      (foldr (\d -> GlobDir [Literal d])+             (GlobFile [WildCard, Literal ".cabal"]) dirComponents)+  where+    (root, dirComponents) = fmap splitDirectories (splitDrive dir)+++--TODO: [code cleanup] use sufficiently recent transformers package+mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)+mplusMaybeT ma mb = do+  mx <- ma+  case mx of+    Nothing -> mb+    Just x  -> return (Just x)+++-------------------------------------------------+-- Fetching and reading packages in the project+--++-- | Read the @.cabal@ files for a set of packages. For remote tarballs and+-- VCS source repos this also fetches them if needed.+--+-- Note here is where we convert from project-root relative paths to absolute+-- paths.+--+fetchAndReadSourcePackages+  :: Verbosity+  -> DistDirLayout+  -> ProjectConfigShared+  -> ProjectConfigBuildOnly+  -> [ProjectPackageLocation]+  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]+fetchAndReadSourcePackages verbosity distDirLayout+                           projectConfigShared+                           projectConfigBuildOnly+                           pkgLocations = do++    pkgsLocalDirectory <-+      sequenceA+        [ readSourcePackageLocalDirectory verbosity dir cabalFile+        | location <- pkgLocations+        , (dir, cabalFile) <- projectPackageLocal location ]++    pkgsLocalTarball <-+      sequenceA+        [ readSourcePackageLocalTarball verbosity path+        | ProjectPackageLocalTarball path <- pkgLocations ]++    pkgsRemoteTarball <- do+      getTransport <- delayInitSharedResource $+                      configureTransport verbosity progPathExtra+                                         preferredHttpTransport+      sequenceA+        [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout+                                                 getTransport uri+        | ProjectPackageRemoteTarball uri <- pkgLocations ]++    pkgsRemoteRepo <-+      syncAndReadSourcePackagesRemoteRepos+        verbosity distDirLayout+        projectConfigShared+        [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ]++    let pkgsNamed =+          [ NamedPackage pkgname [PackagePropertyVersion verrange]+          | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ]++    return $ concat+      [ pkgsLocalDirectory+      , pkgsLocalTarball+      , pkgsRemoteTarball+      , pkgsRemoteRepo+      , pkgsNamed+      ]+  where+    projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)]+    projectPackageLocal (ProjectPackageLocalCabalFile     file) = [(dir, file)]+                                                where dir = takeDirectory file+    projectPackageLocal _ = []++    progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared)+    preferredHttpTransport =+      flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly)++-- | A helper for 'fetchAndReadSourcePackages' to handle the case of+-- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'.+-- We simply read the @.cabal@ file.+--+readSourcePackageLocalDirectory+  :: Verbosity+  -> FilePath  -- ^ The package directory+  -> FilePath  -- ^ The package @.cabal@ file+  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))+readSourcePackageLocalDirectory verbosity dir cabalFile = do+    monitorFiles [monitorFileHashed cabalFile]+    root <- askRoot+    let location = LocalUnpackedPackage (root </> dir)+    liftIO $ fmap (mkSpecificSourcePackage location)+           . readSourcePackageCabalFile verbosity cabalFile+         =<< BS.readFile (root </> cabalFile)+++-- | A helper for 'fetchAndReadSourcePackages' to handle the case of+-- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find+-- the @.cabal@ file and read that.+--+readSourcePackageLocalTarball+  :: Verbosity+  -> FilePath+  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))+readSourcePackageLocalTarball verbosity tarballFile = do+    monitorFiles [monitorFile tarballFile]+    root <- askRoot+    let location = LocalTarballPackage (root </> tarballFile)+    liftIO $ fmap (mkSpecificSourcePackage location)+           . uncurry (readSourcePackageCabalFile verbosity)+         =<< extractTarballPackageCabalFile (root </> tarballFile)++-- | A helper for 'fetchAndReadSourcePackages' to handle the case of+-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir+-- and after that handle it like the local tarball case.+--+fetchAndReadSourcePackageRemoteTarball+  :: Verbosity+  -> DistDirLayout+  -> Rebuild HttpTransport+  -> URI+  -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))+fetchAndReadSourcePackageRemoteTarball verbosity+                                       DistDirLayout {+                                         distDownloadSrcDirectory+                                       }+                                       getTransport+                                       tarballUri =+    -- The tarball download is expensive so we use another layer of file+    -- monitor to avoid it whenever possible.+    rerunIfChanged verbosity monitor tarballUri $ do++      -- Download+      transport <- getTransport+      liftIO $ do+        transportCheckHttps verbosity transport tarballUri+        notice verbosity ("Downloading " ++ show tarballUri)+        createDirectoryIfMissingVerbose verbosity True+                                        distDownloadSrcDirectory+        _ <- downloadURI transport verbosity tarballUri tarballFile+        return ()++      -- Read+      monitorFiles [monitorFile tarballFile]+      let location = RemoteTarballPackage tarballUri tarballFile+      liftIO $ fmap (mkSpecificSourcePackage location)+             . uncurry (readSourcePackageCabalFile verbosity)+           =<< extractTarballPackageCabalFile tarballFile+  where+    tarballStem = distDownloadSrcDirectory+              </> localFileNameForRemoteTarball tarballUri+    tarballFile = tarballStem <.> "tar.gz"++    monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))+    monitor = newFileMonitor (tarballStem <.> "cache")+++-- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of+-- 'ProjectPackageRemoteRepo'.+--+syncAndReadSourcePackagesRemoteRepos+  :: Verbosity+  -> DistDirLayout+  -> ProjectConfigShared+  -> [SourceRepoList]+  -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]+syncAndReadSourcePackagesRemoteRepos verbosity+                                     DistDirLayout{distDownloadSrcDirectory}+                                     ProjectConfigShared {+                                       projectConfigProgPathExtra+                                     }+                                    repos = do++    repos' <- either reportSourceRepoProblems return $+              validateSourceRepos repos++    -- All 'SourceRepo's grouped by referring to the "same" remote repo+    -- instance. So same location but can differ in commit/tag/branch/subdir.+    let reposByLocation :: Map (RepoType, String)+                               [(SourceRepoList, RepoType)]+        reposByLocation = Map.fromListWith (++)+                            [ ((rtype, rloc), [(repo, vcsRepoType vcs)])+                            | (repo, rloc, rtype, vcs) <- repos' ]++    --TODO: pass progPathExtra on to 'configureVCS'+    let _progPathExtra = fromNubList projectConfigProgPathExtra+    getConfiguredVCS <- delayInitSharedResources $ \repoType ->+                          let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in+                          configureVCS verbosity {-progPathExtra-} vcs++    concat <$> sequenceA+      [ rerunIfChanged verbosity monitor repoGroup' $ do+          vcs' <- getConfiguredVCS repoType+          syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'+      | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation+      , let repoGroup' = map fst repoGroup+            pathStem = distDownloadSrcDirectory+                   </> localFileNameForRemoteRepo primaryRepo+            monitor :: FileMonitor+                         [SourceRepoList]+                         [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]+            monitor  = newFileMonitor (pathStem <.> "cache")+      ]+  where+    syncRepoGroupAndReadSourcePackages+      :: VCS ConfiguredProgram+      -> FilePath+      -> [SourceRepoList]+      -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]+    syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do+        liftIO $ createDirectoryIfMissingVerbose verbosity False+                                                 distDownloadSrcDirectory++        -- For syncing we don't care about different 'SourceRepo' values that+        -- are just different subdirs in the same repo.+        syncSourceRepos verbosity vcs+          [ (repo, repoPath)+          | (repo, _, repoPath) <- repoGroupWithPaths ]++        -- Run post-checkout-command if it is specified+        for_ repoGroupWithPaths $ \(repo, _, repoPath) ->+            for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do+                exitCode <- rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing+                unless (exitCode /= ExitSuccess) $ exitWith exitCode++        -- But for reading we go through each 'SourceRepo' including its subdir+        -- value and have to know which path each one ended up in.+        sequenceA+          [ readPackageFromSourceRepo repoWithSubdir repoPath+          | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths+          , repoWithSubdir <- NE.toList reposWithSubdir ]+      where+        -- So to do both things above, we pair them up here.+        repoGroupWithPaths+          :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]+        repoGroupWithPaths =+          zipWith (\(x, y) z -> (x,y,z))+                  (mapGroup+                      [ (repo { srpSubdir = Proxy }, repo)+                      | repo <- foldMap (NE.toList . srpFanOut) repoGroup+                      ])+                  repoPaths++        mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]+        mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))++        -- The repos in a group are given distinct names by simple enumeration+        -- foo, foo-2, foo-3 etc+        repoPaths :: [FilePath]+        repoPaths = pathStem+                  : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]++    readPackageFromSourceRepo+        :: SourceRepositoryPackage Maybe+        -> FilePath+        -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))+    readPackageFromSourceRepo repo repoPath = do+        let packageDir :: FilePath+            packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)++        entries <- liftIO $ getDirectoryContents packageDir+        --TODO: dcoutts 2018-06-23: wrap exceptions+        case filter (\e -> takeExtension e == ".cabal") entries of+          []       -> liftIO $ throwIO $ NoCabalFileFound packageDir+          (_:_:_)  -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir+          [cabalFileName] -> do+            let cabalFilePath = packageDir </> cabalFileName+            monitorFiles [monitorFileHashed cabalFilePath]+            gpd <- liftIO $ readSourcePackageCabalFile verbosity cabalFilePath =<< BS.readFile cabalFilePath++            -- write sdist tarball, to repoPath-pgkid+            tarball <- liftIO $ packageDirToSdist verbosity gpd packageDir+            let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz"+            liftIO $ LBS.writeFile tarballPath tarball++            let location = RemoteSourceRepoPackage repo tarballPath+            return $ mkSpecificSourcePackage location gpd++    reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a+    reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems++    renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String+    renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"+++-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an+-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package+-- from a given location.+--+mkSpecificSourcePackage :: PackageLocation FilePath+                        -> GenericPackageDescription+                        -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)+mkSpecificSourcePackage location pkg =+    SpecificSourcePackage SourcePackage+      { srcpkgPackageId     = packageId pkg+      , srcpkgDescription   = pkg+      , srcpkgSource        = fmap Just location+      , srcpkgDescrOverride = Nothing+      }+++-- | Errors reported upon failing to parse a @.cabal@ file.+--+data CabalFileParseError = CabalFileParseError+    FilePath           -- ^ @.cabal@ file path+    BS.ByteString      -- ^ @.cabal@ file contents+    (NonEmpty PError)  -- ^ errors+    (Maybe Version)    -- ^ We might discover the spec version the package needs+    [PWarning]         -- ^ warnings+  deriving (Typeable)++-- | Manual instance which skips file contentes+instance Show CabalFileParseError where+    showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10)+        $ showString "CabalFileParseError"+        . showChar ' ' . showsPrec 11 fp+        . showChar ' ' . showsPrec 11 ("" :: String)+        . showChar ' ' . showsPrec 11 es+        . showChar ' ' . showsPrec 11 mv+        . showChar ' ' . showsPrec 11 ws++instance Exception CabalFileParseError+#if MIN_VERSION_base(4,8,0)+  where+  displayException = renderCabalFileParseError+#endif++renderCabalFileParseError :: CabalFileParseError -> String+renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) =+    renderParseError filePath contents errors warnings++-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher+-- verbosity levels and throws 'CabalFileParseError' on failure.+--+readSourcePackageCabalFile :: Verbosity+                           -> FilePath+                           -> BS.ByteString+                           -> IO GenericPackageDescription+readSourcePackageCabalFile verbosity pkgfilename content =+    case runParseResult (parseGenericPackageDescription content) of+      (warnings, Right pkg) -> do+        unless (null warnings) $+          info verbosity (formatWarnings warnings)+        return pkg++      (warnings, Left (mspecVersion, errors)) ->+        throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings+  where+    formatWarnings warnings =+        "The package description file " ++ pkgfilename+     ++ " has warnings: "+     ++ unlines (map (showPWarning pkgfilename) warnings)+++-- | When looking for a package's @.cabal@ file we can find none, or several,+-- both of which are failures.+--+data CabalFileSearchFailure+   = NoCabalFileFound FilePath+   | MultipleCabalFilesFound FilePath+  deriving (Show, Typeable)++instance Exception CabalFileSearchFailure+++-- | Find the @.cabal@ file within a tarball file and return it by value.+--+-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception.+--+extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString)+extractTarballPackageCabalFile tarballFile =+    withBinaryFile tarballFile ReadMode $ \hnd -> do+      content <- LBS.hGetContents hnd+      case extractTarballPackageCabalFilePure tarballFile content of+        Left (Left  e) -> throwIO e+        Left (Right e) -> throwIO e+        Right (fileName, fileContent) ->+          (,) fileName <$> evaluate (LBS.toStrict fileContent)+++-- | Scan through a tar file stream and collect the @.cabal@ file, or fail.+--+extractTarballPackageCabalFilePure :: FilePath+                                   -> LBS.ByteString+                                   -> Either (Either Tar.FormatError+                                                     CabalFileSearchFailure)+                                             (FilePath, LBS.ByteString)+extractTarballPackageCabalFilePure tarballFile =+      check+    . accumEntryMap+    . Tar.filterEntries isCabalFile+    . Tar.read+    . GZipUtils.maybeDecompress+  where+    accumEntryMap = Tar.foldlEntries+                      (\m e -> Map.insert (Tar.entryTarPath e) e m)+                      Map.empty++    check (Left (e, _m)) = Left (Left e)+    check (Right m) = case Map.elems m of+        []     -> Left (Right $ NoCabalFileFound tarballFile)+        [file] -> case Tar.entryContent file of+          Tar.NormalFile content _ -> Right (Tar.entryPath file, content)+          _                        -> Left (Right $ NoCabalFileFound tarballFile)+        _files -> Left (Right $ MultipleCabalFilesFound tarballFile)++    isCabalFile e = case splitPath (Tar.entryPath e) of+      [     _dir, file] -> takeExtension file == ".cabal"+      [".", _dir, file] -> takeExtension file == ".cabal"+      _                 -> False+++-- | The name to use for a local file for a remote tarball 'SourceRepo'.+-- This is deterministic based on the remote tarball URI, and is intended+-- to produce non-clashing file names for different tarballs.+--+localFileNameForRemoteTarball :: URI -> FilePath+localFileNameForRemoteTarball uri =+    mangleName uri+ ++ "-" ++  showHex locationHash ""+  where+    mangleName = truncateString 10 . dropExtension . dropExtension+               . takeFileName . dropTrailingPathSeparator . uriPath++    locationHash :: Word+    locationHash = fromIntegral (Hashable.hash (uriToString id uri ""))+++-- | The name to use for a local file or dir for a remote 'SourceRepo'.+-- This is deterministic based on the source repo identity details, and+-- intended to produce non-clashing file names for different repos.+--+localFileNameForRemoteRepo :: SourceRepoList -> FilePath+localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} =+    mangleName srpLocation ++ "-" ++ showHex locationHash ""+  where+    mangleName = truncateString 10 . dropExtension+               . takeFileName . dropTrailingPathSeparator++    -- just the parts that make up the "identity" of the repo+    locationHash :: Word+    locationHash =+      fromIntegral (Hashable.hash (show srpType, srpLocation))+++-- | Truncate a string, with a visual indication that it is truncated.+truncateString :: Int -> String -> String+truncateString n s | length s <= n = s+                   | otherwise     = take (n-1) s ++ "_"+++-- TODO: add something like this, here or in the project planning+-- Based on the package location, which packages will be built inplace in the+-- build tree vs placed in the store. This has various implications on what we+-- can do with the package, e.g. can we run tests, ghci etc.+--+-- packageIsLocalToProject :: ProjectPackageLocation -> Bool+++---------------------------------------------+-- Checking configuration sanity+--++data BadPerPackageCompilerPaths+   = BadPerPackageCompilerPaths [(PackageName, String)]+#if MIN_VERSION_base(4,8,0)+  deriving (Show, Typeable)+#else+  deriving (Typeable)++instance Show BadPerPackageCompilerPaths where+  show = renderBadPerPackageCompilerPaths+#endif++instance Exception BadPerPackageCompilerPaths where+#if MIN_VERSION_base(4,8,0)+  displayException = renderBadPerPackageCompilerPaths+#endif+--TODO: [nice to have] custom exception subclass for Doc rendering, colour etc++renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String+renderBadPerPackageCompilerPaths+  (BadPerPackageCompilerPaths ((pkgname, progname) : _)) =+    "The path to the compiler program (or programs used by the compiler) "+ ++ "cannot be specified on a per-package basis in the cabal.project file "+ ++ "(i.e. setting the '" ++ progname ++ "-location' for package '"+ ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so "+ ++ "specify the path in a global 'program-locations' section."+ --TODO: [nice to have] better format control so we can pretty-print the+ -- offending part of the project file. Currently the line wrapping breaks any+ -- formatting.+renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths"++-- | The project configuration is not allowed to specify program locations for+-- programs used by the compiler as these have to be the same for each set of+-- packages.+--+-- We cannot check this until we know which programs the compiler uses, which+-- in principle is not until we've configured the compiler.+--+-- Throws 'BadPerPackageCompilerPaths'+--+checkBadPerPackageCompilerPaths :: [ConfiguredProgram]+                                -> Map PackageName PackageConfig+                                -> IO ()+checkBadPerPackageCompilerPaths compilerPrograms packagesConfig =+    case [ (pkgname, progname)+         | let compProgNames = Set.fromList (map programId compilerPrograms)+         ,  (pkgname, pkgconf) <- Map.toList packagesConfig+         , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))+         , progname `Set.member` compProgNames ] of+      [] -> return ()+      ps -> throwIO (BadPerPackageCompilerPaths ps)
+ src/Distribution/Client/ProjectConfig/Legacy.hs view
@@ -0,0 +1,1491 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds #-}++-- | Project configuration, implementation in terms of legacy types.+--+module Distribution.Client.ProjectConfig.Legacy (++    -- * Project config in terms of legacy types+    LegacyProjectConfig,+    parseLegacyProjectConfig,+    showLegacyProjectConfig,++    -- * Conversion to and from legacy config types+    commandLineFlagsToProjectConfig,+    convertLegacyProjectConfig,+    convertLegacyGlobalConfig,+    convertToLegacyProjectConfig,++    -- * Internals, just for tests+    parsePackageLocationTokenQ,+    renderPackageLocationToken,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Types.Flag (parsecFlagAssignment)++import Distribution.Client.ProjectConfig.Types+import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)+import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo)+import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..))+import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)++import Distribution.Client.Config+         ( SavedConfig(..), remoteRepoFields, postProcessRepo )++import Distribution.Client.CmdInstall.ClientInstallFlags+         ( ClientInstallFlags(..), defaultClientInstallFlags+         , clientInstallOptions )++import Distribution.Solver.Types.ConstraintSource++import Distribution.FieldGrammar+import Distribution.Package+import Distribution.Types.SourceRepo (RepoType)+import Distribution.PackageDescription+         ( dispFlagAssignment )+import Distribution.Simple.Compiler+         ( OptimisationLevel(..), DebugInfoLevel(..) )+import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )+import Distribution.Simple.Setup+         ( Flag(Flag), toFlag, fromFlagOrDefault+         , ConfigFlags(..), configureOptions+         , HaddockFlags(..), haddockOptions, defaultHaddockFlags+         , TestFlags(..), testOptions', defaultTestFlags+         , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags+         , programDbPaths', splitArgs+         )+import Distribution.Client.NixStyleOptions (NixStyleFlags (..))+import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags+         , InstallFlags(..), installOptions, defaultInstallFlags )+import Distribution.Simple.Program+         ( programName, knownPrograms )+import Distribution.Simple.Program.Db+         ( ProgramDb, defaultProgramDb )+import Distribution.Simple.Utils+         ( lowercase )+import Distribution.Utils.NubList+         ( toNubList, fromNubList, overNubList )+import Distribution.Simple.LocalBuildInfo+         ( toPathTemplate, fromPathTemplate )++import qualified Distribution.Deprecated.ReadP as Parse+import Distribution.Deprecated.ReadP+         ( ReadP, (+++) )+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( Doc, ($+$) )+import qualified Distribution.Deprecated.ParseUtils as ParseUtils+import Distribution.Deprecated.ParseUtils+         ( ParseResult(..), PError(..), syntaxError, PWarning(..)+         , commaNewLineListFieldParsec, newLineListField, parseTokenQ+         , parseHaskellString, showToken+         , simpleFieldParsec+         )+import Distribution.Client.ParseUtils+import Distribution.Simple.Command+         ( CommandUI(commandOptions), ShowOrParseArgs(..)+         , OptionField, option, reqArg' )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint )+import Distribution.Parsec (ParsecParser)++import qualified Data.Map as Map+import qualified Data.ByteString as BS++import Network.URI (URI (..))++------------------------------------------------------------------+-- Representing the project config file in terms of legacy types+--++-- | We already have parsers\/pretty-printers for almost all the fields in the+-- project config file, but they're in terms of the types used for the command+-- line flags for Setup.hs or cabal commands. We don't want to redefine them+-- all, at least not yet so for the moment we use the parsers at the old types+-- and use conversion functions.+--+-- Ultimately if\/when this project-based approach becomes the default then we+-- can redefine the parsers directly for the new types.+--+data LegacyProjectConfig = LegacyProjectConfig {+       legacyPackages          :: [String],+       legacyPackagesOptional  :: [String],+       legacyPackagesRepo      :: [SourceRepoList],+       legacyPackagesNamed     :: [PackageVersionConstraint],++       legacySharedConfig      :: LegacySharedConfig,+       legacyAllConfig         :: LegacyPackageConfig,+       legacyLocalConfig       :: LegacyPackageConfig,+       legacySpecificConfig    :: MapMappend PackageName LegacyPackageConfig+     } deriving (Show, Generic)++instance Monoid LegacyProjectConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacyProjectConfig where+  (<>) = gmappend++data LegacyPackageConfig = LegacyPackageConfig {+       legacyConfigureFlags    :: ConfigFlags,+       legacyInstallPkgFlags   :: InstallFlags,+       legacyHaddockFlags      :: HaddockFlags,+       legacyTestFlags         :: TestFlags,+       legacyBenchmarkFlags    :: BenchmarkFlags+     } deriving (Show, Generic)++instance Monoid LegacyPackageConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacyPackageConfig where+  (<>) = gmappend++data LegacySharedConfig = LegacySharedConfig {+       legacyGlobalFlags       :: GlobalFlags,+       legacyConfigureShFlags  :: ConfigFlags,+       legacyConfigureExFlags  :: ConfigExFlags,+       legacyInstallFlags      :: InstallFlags,+       legacyClientInstallFlags:: ClientInstallFlags,+       legacyProjectFlags      :: ProjectFlags+     } deriving (Show, Generic)++instance Monoid LegacySharedConfig where+  mempty  = gmempty+  mappend = (<>)++instance Semigroup LegacySharedConfig where+  (<>) = gmappend+++------------------------------------------------------------------+-- Converting from and to the legacy types+--++-- | Convert configuration from the @cabal configure@ or @cabal build@ command+-- line into a 'ProjectConfig' value that can combined with configuration from+-- other sources.+--+-- At the moment this uses the legacy command line flag types. See+-- 'LegacyProjectConfig' for an explanation.+--+commandLineFlagsToProjectConfig :: GlobalFlags+                                -> NixStyleFlags a+                                -> ClientInstallFlags+                                -> ProjectConfig+commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags =+    mempty {+      projectConfigBuildOnly     = convertLegacyBuildOnlyFlags+                                     globalFlags configFlags+                                     installFlags clientInstallFlags+                                     haddockFlags testFlags benchmarkFlags,+      projectConfigShared        = convertLegacyAllPackageFlags+                                     globalFlags configFlags+                                     configExFlags installFlags projectFlags,+      projectConfigLocalPackages = localConfig,+      projectConfigAllPackages   = allConfig+    }+  where (localConfig, allConfig) = splitConfig+                                 (convertLegacyPerPackageFlags+                                    configFlags installFlags+                                    haddockFlags testFlags benchmarkFlags)+        -- split the package config (from command line arguments) into+        -- those applied to all packages and those to local only.+        --+        -- for now we will just copy over the ProgramPaths/Args/Extra into+        -- the AllPackages.  The LocalPackages do not inherit them from+        -- AllPackages, and as such need to retain them.+        --+        -- The general decision rule for what to put into allConfig+        -- into localConfig is the following:+        --+        -- - anything that is host/toolchain/env specific should be applied+        --   to all packages, as packagesets have to be host/toolchain/env+        --   consistent.+        -- - anything else should be in the local config and could potentially+        --   be lifted into all-packages vial the `package *` cabal.project+        --   section.+        --+        splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)+        splitConfig pc = (pc+                         , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc+                                  , packageConfigProgramArgs  = packageConfigProgramArgs  pc+                                  , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc+                                  , packageConfigDocumentation = packageConfigDocumentation pc })++-- | Convert from the types currently used for the user-wide @~/.cabal/config@+-- file into the 'ProjectConfig' type.+--+-- Only a subset of the 'ProjectConfig' can be represented in the user-wide+-- config. In particular it does not include packages that are in the project,+-- and it also doesn't support package-specific configuration (only+-- configuration that applies to all packages).+--+convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig+convertLegacyGlobalConfig+    SavedConfig {+      savedGlobalFlags       = globalFlags,+      savedInstallFlags      = installFlags,+      savedClientInstallFlags= clientInstallFlags,+      savedConfigureFlags    = configFlags,+      savedConfigureExFlags  = configExFlags,+      savedUserInstallDirs   = _,+      savedGlobalInstallDirs = _,+      savedUploadFlags       = _,+      savedReportFlags       = _,+      savedHaddockFlags      = haddockFlags,+      savedTestFlags         = testFlags,+      savedBenchmarkFlags    = benchmarkFlags,+      savedProjectFlags      = projectFlags+    } =+    mempty {+      projectConfigBuildOnly   = configBuildOnly,+      projectConfigShared      = configShared,+      projectConfigAllPackages = configAllPackages+    }+  where+    --TODO: [code cleanup] eliminate use of default*Flags here and specify the+    -- defaults in the various resolve functions in terms of the new types.+    configExFlags'      = defaultConfigExFlags      <> configExFlags+    installFlags'       = defaultInstallFlags       <> installFlags+    clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags+    haddockFlags'       = defaultHaddockFlags       <> haddockFlags+    testFlags'          = defaultTestFlags          <> testFlags+    benchmarkFlags'     = defaultBenchmarkFlags     <> benchmarkFlags+    projectFlags'       = defaultProjectFlags       <> projectFlags++    configAllPackages   = convertLegacyPerPackageFlags+                            configFlags installFlags'+                            haddockFlags' testFlags' benchmarkFlags'+    configShared        = convertLegacyAllPackageFlags+                            globalFlags configFlags+                            configExFlags' installFlags' projectFlags'+    configBuildOnly     = convertLegacyBuildOnlyFlags+                            globalFlags configFlags+                            installFlags' clientInstallFlags'+                            haddockFlags' testFlags' benchmarkFlags'+++-- | Convert the project config from the legacy types to the 'ProjectConfig'+-- and associated types. See 'LegacyProjectConfig' for an explanation of the+-- approach.+--+convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig+convertLegacyProjectConfig+  LegacyProjectConfig {+    legacyPackages,+    legacyPackagesOptional,+    legacyPackagesRepo,+    legacyPackagesNamed,+    legacySharedConfig = LegacySharedConfig globalFlags configShFlags+                                            configExFlags installSharedFlags+                                            clientInstallFlags projectFlags,+    legacyAllConfig,+    legacyLocalConfig  = LegacyPackageConfig configFlags installPerPkgFlags+                                             haddockFlags testFlags benchmarkFlags,+    legacySpecificConfig+  } =++    ProjectConfig {+      projectPackages              = legacyPackages,+      projectPackagesOptional      = legacyPackagesOptional,+      projectPackagesRepo          = legacyPackagesRepo,+      projectPackagesNamed         = legacyPackagesNamed,++      projectConfigBuildOnly       = configBuildOnly,+      projectConfigShared          = configPackagesShared,+      projectConfigProvenance      = mempty,+      projectConfigAllPackages     = configAllPackages,+      projectConfigLocalPackages   = configLocalPackages,+      projectConfigSpecificPackage = fmap perPackage legacySpecificConfig+    }+  where+    configAllPackages   = convertLegacyPerPackageFlags g i h t b+                            where LegacyPackageConfig g i h t b = legacyAllConfig+    configLocalPackages = convertLegacyPerPackageFlags+                            configFlags installPerPkgFlags haddockFlags+                            testFlags benchmarkFlags+    configPackagesShared= convertLegacyAllPackageFlags+                            globalFlags (configFlags <> configShFlags)+                            configExFlags installSharedFlags projectFlags+    configBuildOnly     = convertLegacyBuildOnlyFlags+                            globalFlags configShFlags+                            installSharedFlags clientInstallFlags+                            haddockFlags testFlags benchmarkFlags++    perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags+                                    perPkgHaddockFlags perPkgTestFlags+                                    perPkgBenchmarkFlags) =+      convertLegacyPerPackageFlags+        perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags+                          perPkgTestFlags perPkgBenchmarkFlags+++-- | Helper used by other conversion functions that returns the+-- 'ProjectConfigShared' subset of the 'ProjectConfig'.+--+convertLegacyAllPackageFlags+    :: GlobalFlags+    -> ConfigFlags+    -> ConfigExFlags+    -> InstallFlags+    -> ProjectFlags+    -> ProjectConfigShared+convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags =+    ProjectConfigShared{..}+  where+    GlobalFlags {+      globalConfigFile        = projectConfigConfigFile,+      globalRemoteRepos       = projectConfigRemoteRepos,+      globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,+      globalActiveRepos       = projectConfigActiveRepos,+      globalProgPathExtra     = projectConfigProgPathExtra,+      globalStoreDir          = projectConfigStoreDir+    } = globalFlags++    ConfigFlags {+      configDistPref            = projectConfigDistDir,+      configHcFlavor            = projectConfigHcFlavor,+      configHcPath              = projectConfigHcPath,+      configHcPkg               = projectConfigHcPkg+    --configProgramPathExtra    = projectConfigProgPathExtra DELETE ME+    --configInstallDirs         = projectConfigInstallDirs,+    --configUserInstall         = projectConfigUserInstall,+    --configPackageDBs          = projectConfigPackageDBs,+    } = configFlags++    ConfigExFlags {+      configCabalVersion        = projectConfigCabalVersion,+      configExConstraints       = projectConfigConstraints,+      configPreferences         = projectConfigPreferences,+      configSolver              = projectConfigSolver,+      configAllowOlder          = projectConfigAllowOlder,+      configAllowNewer          = projectConfigAllowNewer,+      configWriteGhcEnvironmentFilesPolicy+                                = projectConfigWriteGhcEnvironmentFilesPolicy+    } = configExFlags++    InstallFlags {+      installHaddockIndex       = projectConfigHaddockIndex,+    --installReinstall          = projectConfigReinstall,+    --installAvoidReinstalls    = projectConfigAvoidReinstalls,+    --installOverrideReinstall  = projectConfigOverrideReinstall,+      installIndexState         = projectConfigIndexState,+      installMaxBackjumps       = projectConfigMaxBackjumps,+    --installUpgradeDeps        = projectConfigUpgradeDeps,+      installReorderGoals       = projectConfigReorderGoals,+      installCountConflicts     = projectConfigCountConflicts,+      installFineGrainedConflicts = projectConfigFineGrainedConflicts,+      installMinimizeConflictSet = projectConfigMinimizeConflictSet,+      installPerComponent       = projectConfigPerComponent,+      installIndependentGoals   = projectConfigIndependentGoals,+    --installShadowPkgs         = projectConfigShadowPkgs,+      installStrongFlags        = projectConfigStrongFlags,+      installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,+      installOnlyConstrained    = projectConfigOnlyConstrained+    } = installFlags++    ProjectFlags+        { flagProjectFileName = projectConfigProjectFile+        , flagIgnoreProject   = projectConfigIgnoreProject+        } = projectFlags++-- | Helper used by other conversion functions that returns the+-- 'PackageConfig' subset of the 'ProjectConfig'.+--+convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags+                             -> TestFlags -> BenchmarkFlags -> PackageConfig+convertLegacyPerPackageFlags configFlags installFlags+                             haddockFlags testFlags benchmarkFlags =+    PackageConfig{..}+  where+    ConfigFlags {+      configProgramPaths,+      configProgramArgs,+      configProgramPathExtra    = packageConfigProgramPathExtra,+      configVanillaLib          = packageConfigVanillaLib,+      configProfLib             = packageConfigProfLib,+      configSharedLib           = packageConfigSharedLib,+      configStaticLib           = packageConfigStaticLib,+      configDynExe              = packageConfigDynExe,+      configFullyStaticExe      = packageConfigFullyStaticExe,+      configProfExe             = packageConfigProfExe,+      configProf                = packageConfigProf,+      configProfDetail          = packageConfigProfDetail,+      configProfLibDetail       = packageConfigProfLibDetail,+      configConfigureArgs       = packageConfigConfigureArgs,+      configOptimization        = packageConfigOptimization,+      configProgPrefix          = packageConfigProgPrefix,+      configProgSuffix          = packageConfigProgSuffix,+      configGHCiLib             = packageConfigGHCiLib,+      configSplitSections       = packageConfigSplitSections,+      configSplitObjs           = packageConfigSplitObjs,+      configStripExes           = packageConfigStripExes,+      configStripLibs           = packageConfigStripLibs,+      configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,+      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,+      configConfigurationsFlags = packageConfigFlagAssignment,+      configTests               = packageConfigTests,+      configBenchmarks          = packageConfigBenchmarks,+      configCoverage            = coverage,+      configLibCoverage         = libcoverage, --deprecated+      configDebugInfo           = packageConfigDebugInfo,+      configRelocatable         = packageConfigRelocatable+    } = configFlags+    packageConfigProgramPaths   = MapLast    (Map.fromList configProgramPaths)+    packageConfigProgramArgs    = MapMappend (Map.fromListWith (++) configProgramArgs)++    packageConfigCoverage       = coverage <> libcoverage+    --TODO: defer this merging to the resolve phase++    InstallFlags {+      installDocumentation      = packageConfigDocumentation,+      installRunTests           = packageConfigRunTests+    } = installFlags++    HaddockFlags {+      haddockHoogle             = packageConfigHaddockHoogle,+      haddockHtml               = packageConfigHaddockHtml,+      haddockHtmlLocation       = packageConfigHaddockHtmlLocation,+      haddockForeignLibs        = packageConfigHaddockForeignLibs,+      haddockForHackage         = packageConfigHaddockForHackage,+      haddockExecutables        = packageConfigHaddockExecutables,+      haddockTestSuites         = packageConfigHaddockTestSuites,+      haddockBenchmarks         = packageConfigHaddockBenchmarks,+      haddockInternal           = packageConfigHaddockInternal,+      haddockCss                = packageConfigHaddockCss,+      haddockLinkedSource       = packageConfigHaddockLinkedSource,+      haddockQuickJump          = packageConfigHaddockQuickJump,+      haddockHscolourCss        = packageConfigHaddockHscolourCss,+      haddockContents           = packageConfigHaddockContents+    } = haddockFlags++    TestFlags {+      testHumanLog              = packageConfigTestHumanLog,+      testMachineLog            = packageConfigTestMachineLog,+      testShowDetails           = packageConfigTestShowDetails,+      testKeepTix               = packageConfigTestKeepTix,+      testWrapper               = packageConfigTestWrapper,+      testFailWhenNoTestSuites  = packageConfigTestFailWhenNoTestSuites,+      testOptions               = packageConfigTestTestOptions+    } = testFlags++    BenchmarkFlags {+      benchmarkOptions          = packageConfigBenchmarkOptions+    } = benchmarkFlags+++-- | Helper used by other conversion functions that returns the+-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.+--+convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags+                            -> InstallFlags -> ClientInstallFlags+                            -> HaddockFlags -> TestFlags+                            -> BenchmarkFlags+                            -> ProjectConfigBuildOnly+convertLegacyBuildOnlyFlags globalFlags configFlags+                              installFlags clientInstallFlags+                              haddockFlags _ _ =+    ProjectConfigBuildOnly{..}+  where+    projectConfigClientInstallFlags = clientInstallFlags+    GlobalFlags {+      globalCacheDir          = projectConfigCacheDir,+      globalLogsDir           = projectConfigLogsDir,+      globalWorldFile         = _,+      globalHttpTransport     = projectConfigHttpTransport,+      globalIgnoreExpiry      = projectConfigIgnoreExpiry+    } = globalFlags++    ConfigFlags {+      configVerbosity           = projectConfigVerbosity+    } = configFlags++    InstallFlags {+      installDryRun             = projectConfigDryRun,+      installOnlyDownload       = projectConfigOnlyDownload,+      installOnly               = _,+      installOnlyDeps           = projectConfigOnlyDeps,+      installRootCmd            = _,+      installSummaryFile        = projectConfigSummaryFile,+      installLogFile            = projectConfigLogFile,+      installBuildReports       = projectConfigBuildReports,+      installReportPlanningFailure = projectConfigReportPlanningFailure,+      installSymlinkBinDir      = projectConfigSymlinkBinDir,+      installOneShot            = projectConfigOneShot,+      installNumJobs            = projectConfigNumJobs,+      installKeepGoing          = projectConfigKeepGoing,+      installOfflineMode        = projectConfigOfflineMode+    } = installFlags++    HaddockFlags {+      haddockKeepTempFiles      = projectConfigKeepTempFiles --TODO: this ought to live elsewhere+    } = haddockFlags+++convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig+convertToLegacyProjectConfig+    projectConfig@ProjectConfig {+      projectPackages,+      projectPackagesOptional,+      projectPackagesRepo,+      projectPackagesNamed,+      projectConfigAllPackages,+      projectConfigLocalPackages,+      projectConfigSpecificPackage+    } =+    LegacyProjectConfig {+      legacyPackages         = projectPackages,+      legacyPackagesOptional = projectPackagesOptional,+      legacyPackagesRepo     = projectPackagesRepo,+      legacyPackagesNamed    = projectPackagesNamed,+      legacySharedConfig     = convertToLegacySharedConfig projectConfig,+      legacyAllConfig        = convertToLegacyPerPackageConfig+                                 projectConfigAllPackages,+      legacyLocalConfig      = convertToLegacyAllPackageConfig projectConfig+                            <> convertToLegacyPerPackageConfig+                                 projectConfigLocalPackages,+      legacySpecificConfig   = fmap convertToLegacyPerPackageConfig+                                    projectConfigSpecificPackage+    }++convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig+convertToLegacySharedConfig+    ProjectConfig {+      projectConfigBuildOnly     = ProjectConfigBuildOnly {..},+      projectConfigShared        = ProjectConfigShared {..},+      projectConfigAllPackages   = PackageConfig {+        packageConfigDocumentation+      }+    } =++    LegacySharedConfig+      { legacyGlobalFlags        = globalFlags+      , legacyConfigureShFlags   = configFlags+      , legacyConfigureExFlags   = configExFlags+      , legacyInstallFlags       = installFlags+      , legacyClientInstallFlags = projectConfigClientInstallFlags+      , legacyProjectFlags       = projectFlags+      }+  where+    globalFlags = GlobalFlags {+      globalVersion           = mempty,+      globalNumericVersion    = mempty,+      globalConfigFile        = projectConfigConfigFile,+      globalConstraintsFile   = mempty,+      globalRemoteRepos       = projectConfigRemoteRepos,+      globalCacheDir          = projectConfigCacheDir,+      globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,+      globalActiveRepos       = projectConfigActiveRepos,+      globalLogsDir           = projectConfigLogsDir,+      globalWorldFile         = mempty,+      globalIgnoreExpiry      = projectConfigIgnoreExpiry,+      globalHttpTransport     = projectConfigHttpTransport,+      globalNix               = mempty,+      globalStoreDir          = projectConfigStoreDir,+      globalProgPathExtra     = projectConfigProgPathExtra+    }++    configFlags = mempty {+      configVerbosity     = projectConfigVerbosity,+      configDistPref      = projectConfigDistDir+    }++    configExFlags = ConfigExFlags {+      configCabalVersion  = projectConfigCabalVersion,+      configExConstraints = projectConfigConstraints,+      configPreferences   = projectConfigPreferences,+      configSolver        = projectConfigSolver,+      configAllowOlder    = projectConfigAllowOlder,+      configAllowNewer    = projectConfigAllowNewer,+      configWriteGhcEnvironmentFilesPolicy+                          = projectConfigWriteGhcEnvironmentFilesPolicy+    }++    installFlags = InstallFlags {+      installDocumentation     = packageConfigDocumentation,+      installHaddockIndex      = projectConfigHaddockIndex,+      installDest              = Flag NoCopyDest,+      installDryRun            = projectConfigDryRun,+      installOnlyDownload      = projectConfigOnlyDownload,+      installReinstall         = mempty, --projectConfigReinstall,+      installAvoidReinstalls   = mempty, --projectConfigAvoidReinstalls,+      installOverrideReinstall = mempty, --projectConfigOverrideReinstall,+      installMaxBackjumps      = projectConfigMaxBackjumps,+      installUpgradeDeps       = mempty, --projectConfigUpgradeDeps,+      installReorderGoals      = projectConfigReorderGoals,+      installCountConflicts    = projectConfigCountConflicts,+      installFineGrainedConflicts = projectConfigFineGrainedConflicts,+      installMinimizeConflictSet = projectConfigMinimizeConflictSet,+      installIndependentGoals  = projectConfigIndependentGoals,+      installShadowPkgs        = mempty, --projectConfigShadowPkgs,+      installStrongFlags       = projectConfigStrongFlags,+      installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,+      installOnlyConstrained   = projectConfigOnlyConstrained,+      installOnly              = mempty,+      installOnlyDeps          = projectConfigOnlyDeps,+      installIndexState        = projectConfigIndexState,+      installRootCmd           = mempty, --no longer supported+      installSummaryFile       = projectConfigSummaryFile,+      installLogFile           = projectConfigLogFile,+      installBuildReports      = projectConfigBuildReports,+      installReportPlanningFailure = projectConfigReportPlanningFailure,+      installSymlinkBinDir     = projectConfigSymlinkBinDir,+      installPerComponent      = projectConfigPerComponent,+      installOneShot           = projectConfigOneShot,+      installNumJobs           = projectConfigNumJobs,+      installKeepGoing         = projectConfigKeepGoing,+      installRunTests          = mempty,+      installOfflineMode       = projectConfigOfflineMode+    }++    projectFlags = ProjectFlags+        { flagProjectFileName = projectConfigProjectFile+        , flagIgnoreProject   = projectConfigIgnoreProject+        }+++convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig+convertToLegacyAllPackageConfig+    ProjectConfig {+      projectConfigBuildOnly = ProjectConfigBuildOnly {..},+      projectConfigShared    = ProjectConfigShared {..}+    } =++    LegacyPackageConfig {+      legacyConfigureFlags = configFlags,+      legacyInstallPkgFlags= mempty,+      legacyHaddockFlags   = haddockFlags,+      legacyTestFlags      = mempty,+      legacyBenchmarkFlags = mempty+    }+  where+    configFlags = ConfigFlags {+      configArgs                = mempty,+      configPrograms_           = mempty,+      configProgramPaths        = mempty,+      configProgramArgs         = mempty,+      configProgramPathExtra    = mempty,+      configHcFlavor            = projectConfigHcFlavor,+      configHcPath              = projectConfigHcPath,+      configHcPkg               = projectConfigHcPkg,+      configInstantiateWith     = mempty,+      configVanillaLib          = mempty,+      configProfLib             = mempty,+      configSharedLib           = mempty,+      configStaticLib           = mempty,+      configDynExe              = mempty,+      configFullyStaticExe      = mempty,+      configProfExe             = mempty,+      configProf                = mempty,+      configProfDetail          = mempty,+      configProfLibDetail       = mempty,+      configConfigureArgs       = mempty,+      configOptimization        = mempty,+      configProgPrefix          = mempty,+      configProgSuffix          = mempty,+      configInstallDirs         = mempty,+      configScratchDir          = mempty,+      configDistPref            = mempty,+      configCabalFilePath       = mempty,+      configVerbosity           = mempty,+      configUserInstall         = mempty, --projectConfigUserInstall,+      configPackageDBs          = mempty, --projectConfigPackageDBs,+      configGHCiLib             = mempty,+      configSplitSections       = mempty,+      configSplitObjs           = mempty,+      configStripExes           = mempty,+      configStripLibs           = mempty,+      configExtraLibDirs        = mempty,+      configExtraFrameworkDirs  = mempty,+      configConstraints         = mempty,+      configDependencies        = mempty,+      configExtraIncludeDirs    = mempty,+      configDeterministic       = mempty,+      configIPID                = mempty,+      configCID                 = mempty,+      configConfigurationsFlags = mempty,+      configTests               = mempty,+      configCoverage            = mempty, --TODO: don't merge+      configLibCoverage         = mempty, --TODO: don't merge+      configExactConfiguration  = mempty,+      configBenchmarks          = mempty,+      configFlagError           = mempty,                --TODO: ???+      configRelocatable         = mempty,+      configDebugInfo           = mempty,+      configUseResponseFiles    = mempty,+      configAllowDependingOnPrivateLibs = mempty+    }++    haddockFlags = mempty {+      haddockKeepTempFiles = projectConfigKeepTempFiles+    }+++convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig+convertToLegacyPerPackageConfig PackageConfig {..} =+    LegacyPackageConfig {+      legacyConfigureFlags  = configFlags,+      legacyInstallPkgFlags = installFlags,+      legacyHaddockFlags    = haddockFlags,+      legacyTestFlags       = testFlags,+      legacyBenchmarkFlags  = benchmarkFlags+    }+  where+    configFlags = ConfigFlags {+      configArgs                = mempty,+      configPrograms_           = configPrograms_ mempty,+      configProgramPaths        = Map.toList (getMapLast packageConfigProgramPaths),+      configProgramArgs         = Map.toList (getMapMappend packageConfigProgramArgs),+      configProgramPathExtra    = packageConfigProgramPathExtra,+      configHcFlavor            = mempty,+      configHcPath              = mempty,+      configHcPkg               = mempty,+      configInstantiateWith     = mempty,+      configVanillaLib          = packageConfigVanillaLib,+      configProfLib             = packageConfigProfLib,+      configSharedLib           = packageConfigSharedLib,+      configStaticLib           = packageConfigStaticLib,+      configDynExe              = packageConfigDynExe,+      configFullyStaticExe      = packageConfigFullyStaticExe,+      configProfExe             = packageConfigProfExe,+      configProf                = packageConfigProf,+      configProfDetail          = packageConfigProfDetail,+      configProfLibDetail       = packageConfigProfLibDetail,+      configConfigureArgs       = packageConfigConfigureArgs,+      configOptimization        = packageConfigOptimization,+      configProgPrefix          = packageConfigProgPrefix,+      configProgSuffix          = packageConfigProgSuffix,+      configInstallDirs         = mempty,+      configScratchDir          = mempty,+      configDistPref            = mempty,+      configCabalFilePath       = mempty,+      configVerbosity           = mempty,+      configUserInstall         = mempty,+      configPackageDBs          = mempty,+      configGHCiLib             = packageConfigGHCiLib,+      configSplitSections       = packageConfigSplitSections,+      configSplitObjs           = packageConfigSplitObjs,+      configStripExes           = packageConfigStripExes,+      configStripLibs           = packageConfigStripLibs,+      configExtraLibDirs        = packageConfigExtraLibDirs,+      configExtraFrameworkDirs  = packageConfigExtraFrameworkDirs,+      configConstraints         = mempty,+      configDependencies        = mempty,+      configExtraIncludeDirs    = packageConfigExtraIncludeDirs,+      configIPID                = mempty,+      configCID                 = mempty,+      configDeterministic       = mempty,+      configConfigurationsFlags = packageConfigFlagAssignment,+      configTests               = packageConfigTests,+      configCoverage            = packageConfigCoverage, --TODO: don't merge+      configLibCoverage         = packageConfigCoverage, --TODO: don't merge+      configExactConfiguration  = mempty,+      configBenchmarks          = packageConfigBenchmarks,+      configFlagError           = mempty,                --TODO: ???+      configRelocatable         = packageConfigRelocatable,+      configDebugInfo           = packageConfigDebugInfo,+      configUseResponseFiles    = mempty,+      configAllowDependingOnPrivateLibs = mempty+    }++    installFlags = mempty {+      installDocumentation      = packageConfigDocumentation,+      installRunTests           = packageConfigRunTests+    }++    haddockFlags = HaddockFlags {+      haddockProgramPaths  = mempty,+      haddockProgramArgs   = mempty,+      haddockHoogle        = packageConfigHaddockHoogle,+      haddockHtml          = packageConfigHaddockHtml,+      haddockHtmlLocation  = packageConfigHaddockHtmlLocation,+      haddockForHackage    = packageConfigHaddockForHackage,+      haddockForeignLibs   = packageConfigHaddockForeignLibs,+      haddockExecutables   = packageConfigHaddockExecutables,+      haddockTestSuites    = packageConfigHaddockTestSuites,+      haddockBenchmarks    = packageConfigHaddockBenchmarks,+      haddockInternal      = packageConfigHaddockInternal,+      haddockCss           = packageConfigHaddockCss,+      haddockLinkedSource  = packageConfigHaddockLinkedSource,+      haddockQuickJump     = packageConfigHaddockQuickJump,+      haddockHscolourCss   = packageConfigHaddockHscolourCss,+      haddockContents      = packageConfigHaddockContents,+      haddockDistPref      = mempty,+      haddockKeepTempFiles = mempty,+      haddockVerbosity     = mempty,+      haddockCabalFilePath = mempty,+      haddockArgs          = mempty+    }++    testFlags = TestFlags {+      testDistPref    = mempty,+      testVerbosity   = mempty,+      testHumanLog    = packageConfigTestHumanLog,+      testMachineLog  = packageConfigTestMachineLog,+      testShowDetails = packageConfigTestShowDetails,+      testKeepTix     = packageConfigTestKeepTix,+      testWrapper     = packageConfigTestWrapper,+      testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,+      testOptions     = packageConfigTestTestOptions+    }++    benchmarkFlags = BenchmarkFlags {+      benchmarkDistPref  = mempty,+      benchmarkVerbosity = mempty,+      benchmarkOptions   = packageConfigBenchmarkOptions+    }++------------------------------------------------+-- Parsing and showing the project config file+--++parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig+parseLegacyProjectConfig source =+    parseConfig (legacyProjectConfigFieldDescrs constraintSrc)+                legacyPackageConfigSectionDescrs+                legacyPackageConfigFGSectionDescrs+                mempty+  where+    constraintSrc = ConstraintSourceProjectConfig source++showLegacyProjectConfig :: LegacyProjectConfig -> String+showLegacyProjectConfig config =+    Disp.render $+    showConfig  (legacyProjectConfigFieldDescrs constraintSrc)+                legacyPackageConfigSectionDescrs+                legacyPackageConfigFGSectionDescrs+                config+  $+$+    Disp.text ""+  where+    -- Note: ConstraintSource is unused when pretty-printing. We fake+    -- it here to avoid having to pass it on call-sites. It's not great+    -- but requires re-work of how we annotate provenance.+    constraintSrc = ConstraintSourceProjectConfig "unused"+++legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig]+legacyProjectConfigFieldDescrs constraintSrc =++    [ newLineListField "packages"+        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ+        legacyPackages+        (\v flags -> flags { legacyPackages = v })+    , newLineListField "optional-packages"+        (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ+        legacyPackagesOptional+        (\v flags -> flags { legacyPackagesOptional = v })+    , commaNewLineListFieldParsec "extra-packages"+        pretty parsec+        legacyPackagesNamed+        (\v flags -> flags { legacyPackagesNamed = v })+    ]++ ++ map (liftField+           legacySharedConfig+           (\flags conf -> conf { legacySharedConfig = flags }))+        (legacySharedConfigFieldDescrs constraintSrc)++ ++ map (liftField+           legacyLocalConfig+           (\flags conf -> conf { legacyLocalConfig = flags }))+        legacyPackageConfigFieldDescrs++-- | This is a bit tricky since it has to cover globs which have embedded @,@+-- chars. But we don't just want to parse strictly as a glob since we want to+-- allow http urls which don't parse as globs, and possibly some+-- system-dependent file paths. So we parse fairly liberally as a token, but+-- we allow @,@ inside matched @{}@ braces.+--+parsePackageLocationTokenQ :: ReadP r String+parsePackageLocationTokenQ = parseHaskellString+                   Parse.<++ parsePackageLocationToken+  where+    parsePackageLocationToken :: ReadP r String+    parsePackageLocationToken = fmap fst (Parse.gather outerTerm)+      where+        outerTerm   = alternateEither1 outerToken (braces innerTerm)+        innerTerm   = alternateEither  innerToken (braces innerTerm)+        outerToken  = Parse.munch1 outerChar >> return ()+        innerToken  = Parse.munch1 innerChar >> return ()+        outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')+        innerChar c = not (isSpace c || c == '{' || c == '}')+        braces      = Parse.between (Parse.char '{') (Parse.char '}')++    alternateEither, alternateEither1,+      alternatePQs, alternate1PQs, alternateQsP, alternate1QsP+      :: ReadP r () -> ReadP r () -> ReadP r ()++    alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p+    alternateEither  p q = alternateEither1 p q +++ return ()+    alternate1PQs    p q = p >> alternateQsP q p+    alternatePQs     p q = alternate1PQs p q +++ return ()+    alternate1QsP    q p = Parse.many1 q >> alternatePQs p q+    alternateQsP     q p = alternate1QsP q p +++ return ()++renderPackageLocationToken :: String -> String+renderPackageLocationToken s | needsQuoting = show s+                             | otherwise    = s+  where+    needsQuoting  = not (ok 0 s)+                 || s == "." -- . on its own on a line has special meaning+                 || take 2 s == "--" -- on its own line is comment syntax+                 --TODO: [code cleanup] these "." and "--" escaping issues+                 -- ought to be dealt with systematically in ParseUtils.+    ok :: Int -> String -> Bool+    ok n []       = n == 0+    ok _ ('"':_)  = False+    ok n ('{':cs) = ok (n+1) cs+    ok n ('}':cs) = ok (n-1) cs+    ok n (',':cs) = (n > 0) && ok n cs+    ok _ (c:_)+      | isSpace c = False+    ok n (_  :cs) = ok n cs+++legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig]+legacySharedConfigFieldDescrs constraintSrc = concat+  [ liftFields+      legacyGlobalFlags+      (\flags conf -> conf { legacyGlobalFlags = flags })+  . addFields+      [ newLineListField "extra-prog-path-shared-only"+          showTokenQ parseTokenQ+          (fromNubList . globalProgPathExtra)+          (\v conf -> conf { globalProgPathExtra = toNubList v })+      ]+  . filterFields+      [ "remote-repo-cache"+      , "logs-dir", "store-dir", "ignore-expiry", "http-transport"+      , "active-repositories"+      ]+  . commandOptionsToFields+  $ commandOptions (globalCommand []) ParseArgs++  , liftFields+      legacyConfigureShFlags+      (\flags conf -> conf { legacyConfigureShFlags = flags })+  . filterFields ["verbose", "builddir" ]+  . commandOptionsToFields+  $ configureOptions ParseArgs++  , liftFields+      legacyConfigureExFlags+      (\flags conf -> conf { legacyConfigureExFlags = flags })+  . addFields+      [ commaNewLineListFieldParsec "constraints"+        (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)+        configExConstraints (\v conf -> conf { configExConstraints = v })++      , commaNewLineListFieldParsec "preferences"+        pretty parsec+        configPreferences (\v conf -> conf { configPreferences = v })++      , monoidFieldParsec "allow-older"+        (maybe mempty pretty) (fmap Just parsec)+        (fmap unAllowOlder . configAllowOlder)+        (\v conf -> conf { configAllowOlder = fmap AllowOlder v })++      , monoidFieldParsec "allow-newer"+        (maybe mempty pretty) (fmap Just parsec)+        (fmap unAllowNewer . configAllowNewer)+        (\v conf -> conf { configAllowNewer = fmap AllowNewer v })+      ]+  . filterFields+      [ "cabal-lib-version", "solver", "write-ghc-environment-files"+        -- not "constraint" or "preference", we use our own plural ones above+      ]+  . commandOptionsToFields+  $ configureExOptions ParseArgs constraintSrc++  , liftFields+      legacyInstallFlags+      (\flags conf -> conf { legacyInstallFlags = flags })+  . addFields+      [ newLineListField "build-summary"+          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)+          (fromNubList . installSummaryFile)+          (\v conf -> conf { installSummaryFile = toNubList v })+      ]+  . filterFields+      [ "doc-index-file"+      , "root-cmd", "symlink-bindir"+      , "build-log"+      , "remote-build-reporting", "report-planning-failure"+      , "one-shot", "jobs", "keep-going", "offline", "per-component"+        -- solver flags:+      , "max-backjumps", "reorder-goals", "count-conflicts"+      , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals"+      , "strong-flags" , "allow-boot-library-installs"+      , "reject-unconstrained-dependencies", "index-state"+      ]+  . commandOptionsToFields+  $ installOptions ParseArgs++  , liftFields+      legacyClientInstallFlags+      (\flags conf -> conf { legacyClientInstallFlags = flags })+  . commandOptionsToFields+  $ clientInstallOptions ParseArgs++  , liftFields+      legacyProjectFlags+      (\flags conf -> conf { legacyProjectFlags = flags })+  . commandOptionsToFields+  $ projectFlagsOptions ParseArgs++  ]+++legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]+legacyPackageConfigFieldDescrs =+  ( liftFields+      legacyConfigureFlags+      (\flags conf -> conf { legacyConfigureFlags = flags })+  . addFields+      [ newLineListField "extra-include-dirs"+          showTokenQ parseTokenQ+          configExtraIncludeDirs+          (\v conf -> conf { configExtraIncludeDirs = v })+      , newLineListField "extra-lib-dirs"+          showTokenQ parseTokenQ+          configExtraLibDirs+          (\v conf -> conf { configExtraLibDirs = v })+      , newLineListField "extra-framework-dirs"+          showTokenQ parseTokenQ+          configExtraFrameworkDirs+          (\v conf -> conf { configExtraFrameworkDirs = v })+      , newLineListField "extra-prog-path"+          showTokenQ parseTokenQ+          (fromNubList . configProgramPathExtra)+          (\v conf -> conf { configProgramPathExtra = toNubList v })+      , newLineListField "configure-options"+          showTokenQ parseTokenQ+          configConfigureArgs+          (\v conf -> conf { configConfigureArgs = v })+      , simpleFieldParsec "flags"+          dispFlagAssignment parsecFlagAssignment+          configConfigurationsFlags+          (\v conf -> conf { configConfigurationsFlags = v })+      ]+  . filterFields+      [ "with-compiler", "with-hc-pkg"+      , "program-prefix", "program-suffix"+      , "library-vanilla", "library-profiling"+      , "shared", "static", "executable-dynamic", "executable-static"+      , "profiling", "executable-profiling"+      , "profiling-detail", "library-profiling-detail"+      , "library-for-ghci", "split-objs", "split-sections"+      , "executable-stripping", "library-stripping"+      , "tests", "benchmarks"+      , "coverage", "library-coverage"+      , "relocatable"+        -- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"+        -- or "extra-prog-path". We use corrected ones above that parse+        -- as list fields.+      ]+  . commandOptionsToFields+  ) (configureOptions ParseArgs)+ +++    liftFields+      legacyConfigureFlags+      (\flags conf -> conf { legacyConfigureFlags = flags })+    [ overrideFieldCompiler+    , overrideFieldOptimization+    , overrideFieldDebugInfo+    ]+ +++  ( liftFields+      legacyInstallPkgFlags+      (\flags conf -> conf { legacyInstallPkgFlags = flags })+  . filterFields+      [ "documentation", "run-tests"+      ]+  . commandOptionsToFields+  ) (installOptions ParseArgs)+ +++  ( liftFields+      legacyHaddockFlags+      (\flags conf -> conf { legacyHaddockFlags = flags })+  . mapFieldNames+      ("haddock-"++)+  . addFields+      [ simpleFieldParsec "for-hackage"+          -- TODO: turn this into a library function+          (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty)+          haddockForHackage (\v conf -> conf { haddockForHackage = v })+      ]+  . filterFields+      [ "hoogle", "html", "html-location"+      , "foreign-libraries"+      , "executables", "tests", "benchmarks", "all", "internal", "css"+      , "hyperlink-source", "quickjump", "hscolour-css"+      , "contents-location", "keep-temp-files"+      ]+  . commandOptionsToFields+  ) (haddockOptions ParseArgs)+ +++  ( liftFields+      legacyTestFlags+      (\flags conf -> conf { legacyTestFlags = flags })+  . mapFieldNames+      prefixTest+  . addFields+      [ newLineListField "test-options"+          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)+          testOptions+          (\v conf -> conf { testOptions = v })+      ]+  . filterFields+      [ "log", "machine-log", "show-details", "keep-tix-files"+      , "fail-when-no-test-suites", "test-wrapper" ]+  . commandOptionsToFields+  ) (testOptions' ParseArgs)+ +++  ( liftFields+      legacyBenchmarkFlags+      (\flags conf -> conf { legacyBenchmarkFlags = flags })+  . addFields+      [ newLineListField "benchmark-options"+          (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)+          benchmarkOptions+          (\v conf -> conf { benchmarkOptions = v })+      ]+  . filterFields+      []+  . commandOptionsToFields+  ) (benchmarkOptions' ParseArgs)+++  where+    overrideFieldCompiler =+      simpleFieldParsec "compiler"+        (fromFlagOrDefault Disp.empty . fmap pretty)+        (toFlag <$> parsec <|> pure mempty)+        configHcFlavor (\v flags -> flags { configHcFlavor = v })+++    -- TODO: [code cleanup] The following is a hack. The "optimization" and+    -- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.+    -- Instead of a hand-written parser and printer, we should handle this case+    -- properly in the library.++    overrideFieldOptimization =+      liftField configOptimization+                (\v flags -> flags { configOptimization = v }) $+      let name = "optimization" in+      FieldDescr name+        (\f -> case f of+                 Flag NoOptimisation      -> Disp.text "False"+                 Flag NormalOptimisation  -> Disp.text "True"+                 Flag MaximumOptimisation -> Disp.text "2"+                 _                        -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoOptimisation)+           |  str == "True"  -> ParseOk [] (Flag NormalOptimisation)+           |  str == "0"     -> ParseOk [] (Flag NoOptimisation)+           |  str == "1"     -> ParseOk [] (Flag NormalOptimisation)+           |  str == "2"     -> ParseOk [] (Flag MaximumOptimisation)+           | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)+           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalOptimisation)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str+             caseWarning = PWarning $+               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")++    overrideFieldDebugInfo =+      liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $+      let name = "debug-info" in+      FieldDescr name+        (\f -> case f of+                 Flag NoDebugInfo      -> Disp.text "False"+                 Flag MinimalDebugInfo -> Disp.text "1"+                 Flag NormalDebugInfo  -> Disp.text "True"+                 Flag MaximalDebugInfo -> Disp.text "3"+                 _                     -> Disp.empty)+        (\line str _ -> case () of+         _ |  str == "False" -> ParseOk [] (Flag NoDebugInfo)+           |  str == "True"  -> ParseOk [] (Flag NormalDebugInfo)+           |  str == "0"     -> ParseOk [] (Flag NoDebugInfo)+           |  str == "1"     -> ParseOk [] (Flag MinimalDebugInfo)+           |  str == "2"     -> ParseOk [] (Flag NormalDebugInfo)+           |  str == "3"     -> ParseOk [] (Flag MaximalDebugInfo)+           | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)+           | lstr == "true"  -> ParseOk [caseWarning] (Flag NormalDebugInfo)+           | otherwise       -> ParseFailed (NoParse name line)+           where+             lstr = lowercase str+             caseWarning = PWarning $+               "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.")++    prefixTest name | "test-" `isPrefixOf` name = name+                    | otherwise = "test-" ++ name+++legacyPackageConfigFGSectionDescrs+    :: ( FieldGrammar c g, Applicative (g SourceRepoList)+       , c (Identity RepoType)+       , c (List NoCommaFSep FilePathNT String)+       , c (NonEmpty' NoCommaFSep Token String)+       )+    => [FGSectionDescr g LegacyProjectConfig]+legacyPackageConfigFGSectionDescrs =+    [ packageRepoSectionDescr+    ]++legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]+legacyPackageConfigSectionDescrs =+    [ packageSpecificOptionsSectionDescr+    , liftSection+        legacyLocalConfig+        (\flags conf -> conf { legacyLocalConfig = flags })+        programOptionsSectionDescr+    , liftSection+        legacyLocalConfig+        (\flags conf -> conf { legacyLocalConfig = flags })+        programLocationsSectionDescr+    , liftSection+        legacySharedConfig+        (\flags conf -> conf { legacySharedConfig = flags }) $+      liftSection+        legacyGlobalFlags+        (\flags conf -> conf { legacyGlobalFlags = flags })+        remoteRepoSectionDescr+    ]++packageRepoSectionDescr+    :: ( FieldGrammar c g, Applicative (g SourceRepoList)+       , c (Identity RepoType)+       , c (List NoCommaFSep FilePathNT String)+       , c (NonEmpty' NoCommaFSep Token String)+       )+    => FGSectionDescr g LegacyProjectConfig+packageRepoSectionDescr = FGSectionDescr+  { fgSectionName        = "source-repository-package"+  , fgSectionGrammar     = sourceRepositoryPackageGrammar+  , fgSectionGet         = map (\x->("", x)) . legacyPackagesRepo+  , fgSectionSet         =+        \lineno unused pkgrepo projconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'source-repository-package' takes no arguments"+          return projconf {+            legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]+          }+  }++-- | The definitions of all the fields that can appear in the @package pkgfoo@+-- and @package *@ sections of the @cabal.project@-format files.+--+packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig]+packageSpecificOptionsFieldDescrs =+    legacyPackageConfigFieldDescrs+ ++ programOptionsFieldDescrs+      (configProgramArgs . legacyConfigureFlags)+      (\args pkgconf -> pkgconf {+          legacyConfigureFlags = (legacyConfigureFlags pkgconf) {+            configProgramArgs  = args+          }+        }+      )+ ++ liftFields+      legacyConfigureFlags+      (\flags pkgconf -> pkgconf {+          legacyConfigureFlags = flags+        }+      )+      programLocationsFieldDescrs++-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format+-- files. This section is per-package name. The special package @*@ applies to all+-- packages used anywhere by the project, locally or as dependencies.+--+packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig+packageSpecificOptionsSectionDescr =+    SectionDescr {+      sectionName        = "package",+      sectionFields      = packageSpecificOptionsFieldDescrs,+      sectionSubsections = [],+      sectionGet         = \projconf ->+                             [ (prettyShow pkgname, pkgconf)+                             | (pkgname, pkgconf) <-+                                 Map.toList . getMapMappend+                               . legacySpecificConfig $ projconf ]+                          ++ [ ("*", legacyAllConfig projconf) ],+      sectionSet         =+        \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of+          "*" -> return projconf {+                   legacyAllConfig = legacyAllConfig projconf <> pkgconf+                 }+          _   -> do+            pkgname <- case simpleParsec pkgnamestr of+              Just pkgname -> return pkgname+              Nothing      -> syntaxError lineno $+                                  "a 'package' section requires a package name "+                               ++ "as an argument"+            return projconf {+              legacySpecificConfig =+                MapMappend $+                Map.insertWith mappend pkgname pkgconf+                               (getMapMappend $ legacySpecificConfig projconf)+            },+      sectionEmpty       = mempty+    }++programOptionsFieldDescrs :: (a -> [(String, [String])])+                          -> ([(String, [String])] -> a -> a)+                          -> [FieldDescr a]+programOptionsFieldDescrs get' set =+    commandOptionsToFields+  $ programDbOptions+      defaultProgramDb+      ParseArgs get' set++programOptionsSectionDescr :: SectionDescr LegacyPackageConfig+programOptionsSectionDescr =+    SectionDescr {+      sectionName        = "program-options",+      sectionFields      = programOptionsFieldDescrs+                             configProgramArgs+                             (\args conf -> conf { configProgramArgs = args }),+      sectionSubsections = [],+      sectionGet         = (\x->[("", x)])+                         . legacyConfigureFlags,+      sectionSet         =+        \lineno unused confflags pkgconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'program-options' takes no arguments"+          return pkgconf {+            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags+          },+      sectionEmpty       = mempty+    }++programLocationsFieldDescrs :: [FieldDescr ConfigFlags]+programLocationsFieldDescrs =+     commandOptionsToFields+   $ programDbPaths'+       (++ "-location")+       defaultProgramDb+       ParseArgs+       configProgramPaths+       (\paths conf -> conf { configProgramPaths = paths })++programLocationsSectionDescr :: SectionDescr LegacyPackageConfig+programLocationsSectionDescr =+    SectionDescr {+      sectionName        = "program-locations",+      sectionFields      = programLocationsFieldDescrs,+      sectionSubsections = [],+      sectionGet         = (\x->[("", x)])+                         . legacyConfigureFlags,+      sectionSet         =+        \lineno unused confflags pkgconf -> do+          unless (null unused) $+            syntaxError lineno "the section 'program-locations' takes no arguments"+          return pkgconf {+            legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags+          },+      sectionEmpty       = mempty+    }+++-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@+-- 'OptionField'.+programDbOptions+  :: ProgramDb+  -> ShowOrParseArgs+  -> (flags -> [(String, [String])])+  -> ([(String, [String])] -> (flags -> flags))+  -> [OptionField flags]+programDbOptions progDb showOrParseArgs get' set =+  case showOrParseArgs of+    -- we don't want a verbose help text list so we just show a generic one:+    ShowArgs  -> [programOptions  "PROG"]+    ParseArgs -> map (programOptions . programName . fst)+                 (knownPrograms progDb)+  where+    programOptions prog =+      option "" [prog ++ "-options"]+        ("give extra options to " ++ prog)+        get' set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])+           (\progArgs -> [ joinsArgs args+                         | (prog', args) <- progArgs, prog==prog' ]))+++    joinsArgs = unwords . map escape+    escape arg | any isSpace arg = "\"" ++ arg ++ "\""+               | otherwise       = arg+++-- The implementation is slight hack: we parse all as remote repository+-- but if the url schema is file+noindex, we switch to local.+remoteRepoSectionDescr :: SectionDescr GlobalFlags+remoteRepoSectionDescr = SectionDescr+    { sectionName        = "repository"+    , sectionEmpty       = emptyRemoteRepo (RepoName "")+    , sectionFields      = remoteRepoFields+    , sectionSubsections = []+    , sectionGet         = getS+    , sectionSet         = setS+    }+  where+    getS :: GlobalFlags -> [(String, RemoteRepo)]+    getS gf =+        map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))+        +++        map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))++    setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags+    setS lineno reponame repo0 conf = do+        repo1 <- postProcessRepo lineno reponame repo0+        case repo1 of+            Left repo -> return conf+                { globalLocalNoIndexRepos  = overNubList (++[repo]) (globalLocalNoIndexRepos conf)+                }+            Right repo -> return conf+                { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)+                }++    localToRemote :: LocalRepo -> RemoteRepo+    localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name)+        { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")+        }++-------------------------------+-- Local field utils+--++-- | Parser combinator for simple fields which uses the field type's+-- 'Monoid' instance for combining multiple occurrences of the field.+monoidFieldParsec+    :: Monoid a => String -> (a -> Doc) -> ParsecParser a+    -> (b -> a) -> (a -> b -> b) -> FieldDescr b+monoidFieldParsec name showF readF get' set =+  liftField get' set' $ ParseUtils.fieldParsec name showF readF+  where+    set' xs b = set (get' b `mappend` xs) b+++--TODO: [code cleanup] local redefinition that should replace the version in+-- D.ParseUtils called showFilePath. This version escapes "." and "--" which+-- otherwise are special syntax.+showTokenQ :: String -> Doc+showTokenQ ""            = Disp.empty+showTokenQ x@('-':'-':_) = Disp.text (show x)+showTokenQ x@('.':[])    = Disp.text (show x)+showTokenQ x             = showToken x+++-- Handy util+addFields :: [FieldDescr a]+          -> ([FieldDescr a] -> [FieldDescr a])+addFields = (++)
+ src/Distribution/Client/ProjectConfig/Types.hs view
@@ -0,0 +1,460 @@+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++-- | Handling project configuration, types.+--+module Distribution.Client.ProjectConfig.Types (++    -- * Types for project config+    ProjectConfig(..),+    ProjectConfigBuildOnly(..),+    ProjectConfigShared(..),+    ProjectConfigProvenance(..),+    PackageConfig(..),++    -- * Resolving configuration+    SolverSettings(..),+    BuildTimeSettings(..),++    -- * Extra useful Monoids+    MapLast(..),+    MapMappend(..),+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo )+import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) )+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy )+import Distribution.Client.Dependency.Types+         ( PreSolver )+import Distribution.Client.Targets+         ( UserConstraint )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Types.SourceRepo (SourceRepoList)++import Distribution.Client.IndexUtils.IndexState+         ( TotalIndexState )+import Distribution.Client.IndexUtils.ActiveRepos+         ( ActiveRepos )++import Distribution.Client.CmdInstall.ClientInstallFlags+         ( ClientInstallFlags(..) )++import Distribution.Solver.Types.Settings+import Distribution.Solver.Types.ConstraintSource++import Distribution.Package+         ( PackageName, PackageId, UnitId )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint )+import Distribution.Version+         ( Version )+import Distribution.System+         ( Platform )+import Distribution.PackageDescription+         ( FlagAssignment )+import Distribution.Simple.Compiler+         ( Compiler, CompilerFlavor+         , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )+import Distribution.Simple.Setup+         ( Flag, HaddockTarget(..), TestShowDetails(..) )+import Distribution.Simple.InstallDirs+         ( PathTemplate )+import Distribution.Utils.NubList+         ( NubList )++import qualified Data.Map as Map++-------------------------------+-- Project config types+--++-- | This type corresponds directly to what can be written in the+-- @cabal.project@ file. Other sources of configuration can also be injected+-- into this type, such as the user-wide @~/.cabal/config@ file and the+-- command line of @cabal configure@ or @cabal build@.+--+-- Since it corresponds to the external project file it is an instance of+-- 'Monoid' and all the fields can be empty. This also means there has to+-- be a step where we resolve configuration. At a minimum resolving means+-- applying defaults but it can also mean merging information from multiple+-- sources. For example for package-specific configuration the project file+-- can specify configuration that applies to all local packages, and then+-- additional configuration for a specific package.+--+-- Future directions: multiple profiles, conditionals. If we add these+-- features then the gap between configuration as written in the config file+-- and resolved settings we actually use will become even bigger.+--+data ProjectConfig+   = ProjectConfig {++       -- | Packages in this project, including local dirs, local .cabal files+       -- local and remote tarballs. When these are file globs, they must+       -- match at least one package.+       projectPackages              :: [String],++       -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that+       -- file globs are allowed to match nothing. The primary use case for+       -- this is to be able to say @optional-packages: */@ to automagically+       -- pick up deps that we unpack locally without erroring when+       -- there aren't any.+       projectPackagesOptional      :: [String],++       -- | Packages in this project from remote source repositories.+       projectPackagesRepo          :: [SourceRepoList],++       -- | Packages in this project from hackage repositories.+       projectPackagesNamed         :: [PackageVersionConstraint],++       -- See respective types for an explanation of what these+       -- values are about:+       projectConfigBuildOnly       :: ProjectConfigBuildOnly,+       projectConfigShared          :: ProjectConfigShared,+       projectConfigProvenance      :: Set ProjectConfigProvenance,++       -- | Configuration to be applied to *all* packages,+       -- whether named in `cabal.project` or not.+       projectConfigAllPackages     :: PackageConfig,++       -- | Configuration to be applied to *local* packages; i.e.,+       -- any packages which are explicitly named in `cabal.project`.+       projectConfigLocalPackages   :: PackageConfig,+       projectConfigSpecificPackage :: MapMappend PackageName PackageConfig+     }+  deriving (Eq, Show, Generic, Typeable)++-- | That part of the project configuration that only affects /how/ we build+-- and not the /value/ of the things we build. This means this information+-- does not need to be tracked for changes since it does not affect the+-- outcome.+--+data ProjectConfigBuildOnly+   = ProjectConfigBuildOnly {+       projectConfigVerbosity             :: Flag Verbosity,+       projectConfigDryRun                :: Flag Bool,+       projectConfigOnlyDeps              :: Flag Bool,+       projectConfigOnlyDownload          :: Flag Bool,+       projectConfigSummaryFile           :: NubList PathTemplate,+       projectConfigLogFile               :: Flag PathTemplate,+       projectConfigBuildReports          :: Flag ReportLevel,+       projectConfigReportPlanningFailure :: Flag Bool,+       projectConfigSymlinkBinDir         :: Flag FilePath,+       projectConfigOneShot               :: Flag Bool,+       projectConfigNumJobs               :: Flag (Maybe Int),+       projectConfigKeepGoing             :: Flag Bool,+       projectConfigOfflineMode           :: Flag Bool,+       projectConfigKeepTempFiles         :: Flag Bool,+       projectConfigHttpTransport         :: Flag String,+       projectConfigIgnoreExpiry          :: Flag Bool,+       projectConfigCacheDir              :: Flag FilePath,+       projectConfigLogsDir               :: Flag FilePath,+       projectConfigClientInstallFlags    :: ClientInstallFlags+     }+  deriving (Eq, Show, Generic)+++-- | Project configuration that is shared between all packages in the project.+-- In particular this includes configuration that affects the solver.+--+data ProjectConfigShared+   = ProjectConfigShared {+       projectConfigDistDir           :: Flag FilePath,+       projectConfigConfigFile        :: Flag FilePath,+       projectConfigProjectFile       :: Flag FilePath,+       projectConfigIgnoreProject     :: Flag Bool,+       projectConfigHcFlavor          :: Flag CompilerFlavor,+       projectConfigHcPath            :: Flag FilePath,+       projectConfigHcPkg             :: Flag FilePath,+       projectConfigHaddockIndex      :: Flag PathTemplate,++       -- Things that only make sense for manual mode, not --local mode+       -- too much control!+     --projectConfigUserInstall       :: Flag Bool,+     --projectConfigInstallDirs       :: InstallDirs (Flag PathTemplate),+     --TODO: [required eventually] decide what to do with InstallDirs+     -- currently we don't allow it to be specified in the config file+     --projectConfigPackageDBs        :: [Maybe PackageDB],++       -- configuration used both by the solver and other phases+       projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.+       projectConfigLocalNoIndexRepos :: NubList LocalRepo,+       projectConfigActiveRepos       :: Flag ActiveRepos,+       projectConfigIndexState        :: Flag TotalIndexState,+       projectConfigStoreDir          :: Flag FilePath,++       -- solver configuration+       projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],+       projectConfigPreferences       :: [PackageVersionConstraint],+       projectConfigCabalVersion      :: Flag Version,  --TODO: [required eventually] unused+       projectConfigSolver            :: Flag PreSolver,+       projectConfigAllowOlder        :: Maybe AllowOlder,+       projectConfigAllowNewer        :: Maybe AllowNewer,+       projectConfigWriteGhcEnvironmentFilesPolicy+                                      :: Flag WriteGhcEnvironmentFilesPolicy,+       projectConfigMaxBackjumps      :: Flag Int,+       projectConfigReorderGoals      :: Flag ReorderGoals,+       projectConfigCountConflicts    :: Flag CountConflicts,+       projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts,+       projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet,+       projectConfigStrongFlags       :: Flag StrongFlags,+       projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls,+       projectConfigOnlyConstrained   :: Flag OnlyConstrained,+       projectConfigPerComponent      :: Flag Bool,+       projectConfigIndependentGoals  :: Flag IndependentGoals,++       projectConfigProgPathExtra     :: NubList FilePath++       -- More things that only make sense for manual mode, not --local mode+       -- too much control!+     --projectConfigShadowPkgs        :: Flag Bool,+     --projectConfigReinstall         :: Flag Bool,+     --projectConfigAvoidReinstalls   :: Flag Bool,+     --projectConfigOverrideReinstall :: Flag Bool,+     --projectConfigUpgradeDeps       :: Flag Bool+     }+  deriving (Eq, Show, Generic)+++-- | Specifies the provenance of project configuration, whether defaults were+-- used or if the configuration was read from an explicit file path.+data ProjectConfigProvenance++     -- | The configuration is implicit due to no explicit configuration+     -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig'+     -- for how implicit configuration is determined.+   = Implicit++     -- | The path the project configuration was explicitly read from.+     -- | The configuration was explicitly read from the specified 'FilePath'.+   | Explicit FilePath+  deriving (Eq, Ord, Show, Generic)+++-- | Project configuration that is specific to each package, that is where we+-- can in principle have different values for different packages in the same+-- project.+--+data PackageConfig+   = PackageConfig {+       packageConfigProgramPaths        :: MapLast String FilePath,+       packageConfigProgramArgs         :: MapMappend String [String],+       packageConfigProgramPathExtra    :: NubList FilePath,+       packageConfigFlagAssignment      :: FlagAssignment,+       packageConfigVanillaLib          :: Flag Bool,+       packageConfigSharedLib           :: Flag Bool,+       packageConfigStaticLib           :: Flag Bool,+       packageConfigDynExe              :: Flag Bool,+       packageConfigFullyStaticExe      :: Flag Bool,+       packageConfigProf                :: Flag Bool, --TODO: [code cleanup] sort out+       packageConfigProfLib             :: Flag Bool, --      this duplication+       packageConfigProfExe             :: Flag Bool, --      and consistency+       packageConfigProfDetail          :: Flag ProfDetailLevel,+       packageConfigProfLibDetail       :: Flag ProfDetailLevel,+       packageConfigConfigureArgs       :: [String],+       packageConfigOptimization        :: Flag OptimisationLevel,+       packageConfigProgPrefix          :: Flag PathTemplate,+       packageConfigProgSuffix          :: Flag PathTemplate,+       packageConfigExtraLibDirs        :: [FilePath],+       packageConfigExtraFrameworkDirs  :: [FilePath],+       packageConfigExtraIncludeDirs    :: [FilePath],+       packageConfigGHCiLib             :: Flag Bool,+       packageConfigSplitSections       :: Flag Bool,+       packageConfigSplitObjs           :: Flag Bool,+       packageConfigStripExes           :: Flag Bool,+       packageConfigStripLibs           :: Flag Bool,+       packageConfigTests               :: Flag Bool,+       packageConfigBenchmarks          :: Flag Bool,+       packageConfigCoverage            :: Flag Bool,+       packageConfigRelocatable         :: Flag Bool,+       packageConfigDebugInfo           :: Flag DebugInfoLevel,+       packageConfigRunTests            :: Flag Bool, --TODO: [required eventually] use this+       packageConfigDocumentation       :: Flag Bool, --TODO: [required eventually] use this+       -- Haddock options+       packageConfigHaddockHoogle       :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHtml         :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this+       packageConfigHaddockForeignLibs  :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockExecutables  :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockTestSuites   :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockBenchmarks   :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockInternal     :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockCss          :: Flag FilePath, --TODO: [required eventually] use this+       packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockQuickJump    :: Flag Bool, --TODO: [required eventually] use this+       packageConfigHaddockHscolourCss  :: Flag FilePath, --TODO: [required eventually] use this+       packageConfigHaddockContents     :: Flag PathTemplate, --TODO: [required eventually] use this+       packageConfigHaddockForHackage   :: Flag HaddockTarget,+       -- Test options+       packageConfigTestHumanLog        :: Flag PathTemplate,+       packageConfigTestMachineLog      :: Flag PathTemplate,+       packageConfigTestShowDetails     :: Flag TestShowDetails,+       packageConfigTestKeepTix         :: Flag Bool,+       packageConfigTestWrapper         :: Flag FilePath,+       packageConfigTestFailWhenNoTestSuites :: Flag Bool,+       packageConfigTestTestOptions     :: [PathTemplate],+       -- Benchmark options+       packageConfigBenchmarkOptions    :: [PathTemplate]+     }+  deriving (Eq, Show, Generic)++instance Binary ProjectConfig+instance Binary ProjectConfigBuildOnly+instance Binary ProjectConfigShared+instance Binary ProjectConfigProvenance+instance Binary PackageConfig++instance Structured ProjectConfig+instance Structured ProjectConfigBuildOnly+instance Structured ProjectConfigShared+instance Structured ProjectConfigProvenance+instance Structured PackageConfig++-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes+-- the last value rather than the first value for overlapping keys.+newtype MapLast k v = MapLast { getMapLast :: Map k v }+  deriving (Eq, Show, Functor, Generic, Binary, Typeable)++instance (Structured k, Structured v) => Structured (MapLast k v)++instance Ord k => Monoid (MapLast k v) where+  mempty  = MapLast Map.empty+  mappend = (<>)++instance Ord k => Semigroup (MapLast k v) where+  MapLast a <> MapLast b = MapLast $ Map.union b a+  -- rather than Map.union which is the normal Map monoid instance+++-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that+-- 'mappend's values of overlapping keys rather than taking the first.+newtype MapMappend k v = MapMappend { getMapMappend :: Map k v }+  deriving (Eq, Show, Functor, Generic, Binary, Typeable)++instance (Structured k, Structured v) => Structured (MapMappend k v)++instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where+  mempty  = MapMappend Map.empty+  mappend = (<>)++instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where+  MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b)+  -- rather than Map.union which is the normal Map monoid instance+++instance Monoid ProjectConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfig where+  (<>) = gmappend+++instance Monoid ProjectConfigBuildOnly where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfigBuildOnly where+  (<>) = gmappend+++instance Monoid ProjectConfigShared where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ProjectConfigShared where+  (<>) = gmappend+++instance Monoid PackageConfig where+  mempty = gmempty+  mappend = (<>)++instance Semigroup PackageConfig where+  (<>) = gmappend++----------------------------------------+-- Resolving configuration to settings+--++-- | Resolved configuration for the solver. The idea is that this is easier to+-- use than the raw configuration because in the raw configuration everything+-- is optional (monoidial). In the 'BuildTimeSettings' every field is filled+-- in, if only with the defaults.+--+-- Use 'resolveSolverSettings' to make one from the project config (by+-- applying defaults etc).+--+data SolverSettings+   = SolverSettings {+       solverSettingRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.+       solverSettingLocalNoIndexRepos :: [LocalRepo],+       solverSettingConstraints       :: [(UserConstraint, ConstraintSource)],+       solverSettingPreferences       :: [PackageVersionConstraint],+       solverSettingFlagAssignment    :: FlagAssignment, -- ^ For all local packages+       solverSettingFlagAssignments   :: Map PackageName FlagAssignment,+       solverSettingCabalVersion      :: Maybe Version,  --TODO: [required eventually] unused+       solverSettingSolver            :: PreSolver,+       solverSettingAllowOlder        :: AllowOlder,+       solverSettingAllowNewer        :: AllowNewer,+       solverSettingMaxBackjumps      :: Maybe Int,+       solverSettingReorderGoals      :: ReorderGoals,+       solverSettingCountConflicts    :: CountConflicts,+       solverSettingFineGrainedConflicts :: FineGrainedConflicts,+       solverSettingMinimizeConflictSet :: MinimizeConflictSet,+       solverSettingStrongFlags       :: StrongFlags,+       solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,+       solverSettingOnlyConstrained   :: OnlyConstrained,+       solverSettingIndexState        :: Maybe TotalIndexState,+       solverSettingActiveRepos       :: Maybe ActiveRepos,+       solverSettingIndependentGoals  :: IndependentGoals+       -- Things that only make sense for manual mode, not --local mode+       -- too much control!+     --solverSettingShadowPkgs        :: Bool,+     --solverSettingReinstall         :: Bool,+     --solverSettingAvoidReinstalls   :: Bool,+     --solverSettingOverrideReinstall :: Bool,+     --solverSettingUpgradeDeps       :: Bool+     }+  deriving (Eq, Show, Generic, Typeable)++instance Binary SolverSettings+instance Structured SolverSettings+++-- | Resolved configuration for things that affect how we build and not the+-- value of the things we build. The idea is that this is easier to use than+-- the raw configuration because in the raw configuration everything is+-- optional (monoidial). In the 'BuildTimeSettings' every field is filled in,+-- if only with the defaults.+--+-- Use 'resolveBuildTimeSettings' to make one from the project config (by+-- applying defaults etc).+--+data BuildTimeSettings+   = BuildTimeSettings {+       buildSettingDryRun                :: Bool,+       buildSettingOnlyDeps              :: Bool,+       buildSettingOnlyDownload          :: Bool,+       buildSettingSummaryFile           :: [PathTemplate],+       buildSettingLogFile               :: Maybe (Compiler  -> Platform+                                                -> PackageId -> UnitId+                                                             -> FilePath),+       buildSettingLogVerbosity          :: Verbosity,+       buildSettingBuildReports          :: ReportLevel,+       buildSettingReportPlanningFailure :: Bool,+       buildSettingSymlinkBinDir         :: [FilePath],+       buildSettingOneShot               :: Bool,+       buildSettingNumJobs               :: Int,+       buildSettingKeepGoing             :: Bool,+       buildSettingOfflineMode           :: Bool,+       buildSettingKeepTempFiles         :: Bool,+       buildSettingRemoteRepos           :: [RemoteRepo],+       buildSettingLocalNoIndexRepos     :: [LocalRepo],+       buildSettingCacheDir              :: FilePath,+       buildSettingHttpTransport         :: Maybe String,+       buildSettingIgnoreExpiry          :: Bool,+       buildSettingProgPathExtra         :: [FilePath]+     }
+ src/Distribution/Client/ProjectFlags.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+module Distribution.Client.ProjectFlags (+    ProjectFlags(..),+    defaultProjectFlags,+    projectFlagsOptions,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.ReadE          (succeedReadE)+import Distribution.Simple.Command (MkOptDescr, OptionField, ShowOrParseArgs (..), boolOpt', option, reqArg)+import Distribution.Simple.Setup   (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)++data ProjectFlags = ProjectFlags+    { flagProjectFileName :: Flag FilePath+      -- ^ The cabal project file name; defaults to @cabal.project@.+      -- The name itself denotes the cabal project file name, but it also+      -- is the base of auxiliary project files, such as+      -- @cabal.project.local@ and @cabal.project.freeze@ which are also+      -- read and written out in some cases.  If the path is not found+      -- in the current working directory, we will successively probe+      -- relative to parent directories until this name is found.++    , flagIgnoreProject   :: Flag Bool+      -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)+      -- The exact interpretation might be slightly different per command.+    }+  deriving (Show, Generic)++defaultProjectFlags :: ProjectFlags+defaultProjectFlags = ProjectFlags+    { flagProjectFileName = mempty+    , flagIgnoreProject   = toFlag False+      -- Should we use 'Last' here?+    }++projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]+projectFlagsOptions showOrParseArgs =+    [ option [] ["project-file"]+        "Set the name of the cabal.project file to search for in parent directories"+        flagProjectFileName (\pf flags -> flags { flagProjectFileName = pf })+        (reqArg "FILE" (succeedReadE Flag) flagToList)+    , option ['z'] ["ignore-project"]+        "Ignore local project configuration"+        flagIgnoreProject (\v flags -> flags { flagIgnoreProject = v })+        (yesNoOpt showOrParseArgs)+    ]++instance Monoid ProjectFlags where+    mempty = gmempty+    mappend = (<>)++instance Semigroup ProjectFlags where+    (<>) = gmappend++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
+ src/Distribution/Client/ProjectOrchestration.hs view
@@ -0,0 +1,1249 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}++-- | This module deals with building and incrementally rebuilding a collection+-- of packages. It is what backs the @cabal build@ and @configure@ commands,+-- as well as being a core part of @run@, @test@, @bench@ and others.+--+-- The primary thing is in fact rebuilding (and trying to make that quick by+-- not redoing unnecessary work), so building from scratch is just a special+-- case.+--+-- The build process and the code can be understood by breaking it down into+-- three major parts:+--+-- * The 'ElaboratedInstallPlan' type+--+-- * The \"what to do\" phase, where we look at the all input configuration+--   (project files, .cabal files, command line etc) and produce a detailed+--   plan of what to do -- the 'ElaboratedInstallPlan'.+--+-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we+-- re-execute it.+--+-- As far as possible, the \"what to do\" phase embodies all the policy, leaving+-- the \"do it\" phase policy free. The first phase contains more of the+-- complicated logic, but it is contained in code that is either pure or just+-- has read effects (except cache updates). Then the second phase does all the+-- actions to build packages, but as far as possible it just follows the+-- instructions and avoids any logic for deciding what to do (apart from+-- recompilation avoidance in executing the plan).+--+-- This division helps us keep the code under control, making it easier to+-- understand, test and debug. So when you are extending these modules, please+-- think about which parts of your change belong in which part. It is+-- perfectly ok to extend the description of what to do (i.e. the+-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the+-- first phase. Also, the second phase does not have direct access to any of+-- the input configuration anyway; all the information has to flow via the+-- 'ElaboratedInstallPlan'.+--+module Distribution.Client.ProjectOrchestration (+    -- * Discovery phase: what is in the project?+    CurrentCommand(..),+    establishProjectBaseContext,+    establishProjectBaseContextWithRoot,+    ProjectBaseContext(..),+    BuildTimeSettings(..),+    commandLineFlagsToProjectConfig,++    -- * Pre-build phase: decide what to do.+    withInstallPlan,+    runProjectPreBuildPhase,+    ProjectBuildContext(..),++    -- ** Selecting what targets we mean+    readTargetSelectors,+    reportTargetSelectorProblems,+    resolveTargets,+    TargetsMap,+    TargetSelector(..),+    TargetImplicitCwd(..),+    PackageId,+    AvailableTarget(..),+    AvailableTargetStatus(..),+    TargetRequested(..),+    ComponentName(..),+    ComponentKind(..),+    ComponentTarget(..),+    SubComponentTarget(..),+    selectComponentTargetBasic,+    distinctTargetComponents,+    -- ** Utils for selecting targets+    filterTargetsKind,+    filterTargetsKindWith,+    selectBuildableTargets,+    selectBuildableTargetsWith,+    selectBuildableTargets',+    selectBuildableTargetsWith',+    forgetTargetsDetail,++    -- ** Adjusting the plan+    pruneInstallPlanToTargets,+    TargetAction(..),+    pruneInstallPlanToDependencies,+    CannotPruneDependencies(..),+    printPlan,++    -- * Build phase: now do it.+    runProjectBuildPhase,++    -- * Post build actions+    runProjectPostBuildPhase,+    dieOnBuildFailures,++    -- * Dummy projects+    establishDummyProjectBaseContext,+    establishDummyDistDirLayout,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+import Distribution.Compat.Directory+         ( makeAbsolute )++import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanning+                   hiding ( pruneInstallPlanToTargets )+import qualified Distribution.Client.ProjectPlanning as ProjectPlanning+                   ( pruneInstallPlanToTargets )+import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.ProjectBuilding+import           Distribution.Client.ProjectPlanOutput+import           Distribution.Client.RebuildMonad ( runRebuild )++import           Distribution.Client.TargetProblem+                   ( TargetProblem (..) )+import           Distribution.Client.Types+                   ( GenericReadyPackage(..), UnresolvedSourcePackage+                   , PackageSpecifier(..)+                   , SourcePackageDb(..)+                   , WriteGhcEnvironmentFilesPolicy(..) )+import           Distribution.Solver.Types.PackageIndex+                   ( lookupPackageName )+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.TargetSelector+                   ( TargetSelector(..), TargetImplicitCwd(..)+                   , ComponentKind(..), componentKind+                   , readTargetSelectors, reportTargetSelectorProblems )+import           Distribution.Client.DistDirLayout+import           Distribution.Client.Config (getCabalDir)+import           Distribution.Client.Setup hiding (packageName)+import           Distribution.Compiler+                   ( CompilerFlavor(GHC) )+import           Distribution.Types.ComponentName+                   ( componentNameString )+import           Distribution.Types.UnqualComponentName+                   ( UnqualComponentName, packageNameToUnqualComponentName )++import           Distribution.Solver.Types.OptionalStanza++import           Distribution.Package+import           Distribution.Types.Flag+                   ( FlagAssignment, showFlagAssignment, diffFlagAssignment )+import           Distribution.Simple.LocalBuildInfo+                   ( ComponentName(..), pkgComponents )+import           Distribution.Simple.Flag+                   ( fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.Setup as Setup+import           Distribution.Simple.Command (commandShowOptions)+import           Distribution.Simple.Configure (computeEffectiveProfiling)++import           Distribution.Simple.Utils+                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose )+import           Distribution.Verbosity+import           Distribution.Version+                   ( mkVersion )+import           Distribution.Simple.Compiler+                   ( compilerCompatVersion, showCompilerId+                   , OptimisationLevel(..))++import qualified Data.List.NonEmpty as NE+import qualified Data.Set as Set+import qualified Data.Map as Map+import           Control.Exception (assert)+#ifdef MIN_VERSION_unix+import           System.Posix.Signals (sigKILL, sigSEGV)+#endif+++-- | Tracks what command is being executed, because we need to hide this somewhere+-- for cases that need special handling (usually for error reporting).+data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand+                    deriving (Show, Eq)++-- | This holds the context of a project prior to solving: the content of the+-- @cabal.project@ and all the local package @.cabal@ files.+--+data ProjectBaseContext = ProjectBaseContext {+       distDirLayout  :: DistDirLayout,+       cabalDirLayout :: CabalDirLayout,+       projectConfig  :: ProjectConfig,+       localPackages  :: [PackageSpecifier UnresolvedSourcePackage],+       buildSettings  :: BuildTimeSettings,+       currentCommand :: CurrentCommand+     }++establishProjectBaseContext+    :: Verbosity+    -> ProjectConfig+    -> CurrentCommand+    -> IO ProjectBaseContext+establishProjectBaseContext verbosity cliConfig currentCommand = do+    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile+    establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand+  where+    mprojectFile   = Setup.flagToMaybe projectConfigProjectFile+    ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig++-- | Like 'establishProjectBaseContext' but doesn't search for project root.+establishProjectBaseContextWithRoot+    :: Verbosity+    -> ProjectConfig+    -> ProjectRoot+    -> CurrentCommand+    -> IO ProjectBaseContext+establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do+    cabalDir <- getCabalDir++    let distDirLayout  = defaultDistDirLayout projectRoot mdistDirectory++    (projectConfig, localPackages) <-+      rebuildProjectConfig verbosity+                           distDirLayout+                           cliConfig++    let ProjectConfigBuildOnly {+          projectConfigLogsDir+        } = projectConfigBuildOnly projectConfig++        ProjectConfigShared {+          projectConfigStoreDir+        } = projectConfigShared projectConfig++        mlogsDir = Setup.flagToMaybe projectConfigLogsDir+    mstoreDir <- sequenceA $ makeAbsolute+                 <$> Setup.flagToMaybe projectConfigStoreDir+    let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir++        buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    -- https://github.com/haskell/cabal/issues/6013+    when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $+        warn verbosity "There are no packages or optional-packages in the project"++    return ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages,+      buildSettings,+      currentCommand+    }+  where+    mdistDirectory = Setup.flagToMaybe projectConfigDistDir+    ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig+++-- | This holds the context between the pre-build, build and post-build phases.+--+data ProjectBuildContext = ProjectBuildContext {+      -- | This is the improved plan, before we select a plan subset based on+      -- the build targets, and before we do the dry-run. So this contains+      -- all packages in the project.+      elaboratedPlanOriginal :: ElaboratedInstallPlan,++      -- | This is the 'elaboratedPlanOriginal' after we select a plan subset+      -- and do the dry-run phase to find out what is up-to or out-of date.+      -- This is the plan that will be executed during the build phase. So+      -- this contains only a subset of packages in the project.+      elaboratedPlanToExecute:: ElaboratedInstallPlan,++      -- | The part of the install plan that's shared between all packages in+      -- the plan. This does not change between the two plan variants above,+      -- so there is just the one copy.+      elaboratedShared       :: ElaboratedSharedConfig,++      -- | The result of the dry-run phase. This tells us about each member of+      -- the 'elaboratedPlanToExecute'.+      pkgsBuildStatus        :: BuildStatusMap,++      -- | The targets selected by @selectPlanSubset@. This is useful eg. in+      -- CmdRun, where we need a valid target to execute.+      targetsMap             :: TargetsMap+    }+++-- | Pre-build phase: decide what to do.+--+withInstallPlan+    :: Verbosity+    -> ProjectBaseContext+    -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)+    -> IO a+withInstallPlan+    verbosity+    ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages+    }+    action = do+    -- Take the project configuration and make a plan for how to build+    -- everything in the project. This is independent of any specific targets+    -- the user has asked for.+    --+    (elaboratedPlan, _, elaboratedShared, _, _) <-+      rebuildInstallPlan verbosity+                         distDirLayout cabalDirLayout+                         projectConfig+                         localPackages+    action elaboratedPlan elaboratedShared++runProjectPreBuildPhase+    :: Verbosity+    -> ProjectBaseContext+    -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))+    -> IO ProjectBuildContext+runProjectPreBuildPhase+    verbosity+    ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages+    }+    selectPlanSubset = do+    -- Take the project configuration and make a plan for how to build+    -- everything in the project. This is independent of any specific targets+    -- the user has asked for.+    --+    (elaboratedPlan, _, elaboratedShared, _, _) <-+      rebuildInstallPlan verbosity+                         distDirLayout cabalDirLayout+                         projectConfig+                         localPackages++    -- The plan for what to do is represented by an 'ElaboratedInstallPlan'++    -- Now given the specific targets the user has asked for, decide+    -- which bits of the plan we will want to execute.+    --+    (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan++    -- Check which packages need rebuilding.+    -- This also gives us more accurate reasons for the --dry-run output.+    --+    pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared+                                            elaboratedPlan'++    -- Improve the plan by marking up-to-date packages as installed.+    --+    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages+                             pkgsBuildStatus elaboratedPlan'+    debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')++    return ProjectBuildContext {+      elaboratedPlanOriginal = elaboratedPlan,+      elaboratedPlanToExecute = elaboratedPlan'',+      elaboratedShared,+      pkgsBuildStatus,+      targetsMap = targets+    }+++-- | Build phase: now do it.+--+-- Execute all or parts of the description of what to do to build or+-- rebuild the various packages needed.+--+runProjectBuildPhase :: Verbosity+                     -> ProjectBaseContext+                     -> ProjectBuildContext+                     -> IO BuildOutcomes+runProjectBuildPhase _ ProjectBaseContext{buildSettings} _+  | buildSettingDryRun buildSettings+  = return Map.empty++runProjectBuildPhase verbosity+                     ProjectBaseContext{..} ProjectBuildContext {..} =+    fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $+    rebuildTargets verbosity+                   distDirLayout+                   (cabalStoreDirLayout cabalDirLayout)+                   elaboratedPlanToExecute+                   elaboratedShared+                   pkgsBuildStatus+                   buildSettings+  where+    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes+    previousBuildOutcomes =+      Map.mapMaybe $ \status -> case status of+        BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)+        --TODO: [nice to have] record build failures persistently+        _                                  -> Nothing++-- | Post-build phase: various administrative tasks+--+-- Update bits of state based on the build outcomes and report any failures.+--+runProjectPostBuildPhase :: Verbosity+                         -> ProjectBaseContext+                         -> ProjectBuildContext+                         -> BuildOutcomes+                         -> IO ()+runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _+  | buildSettingDryRun buildSettings+  = return ()++runProjectPostBuildPhase verbosity+                         ProjectBaseContext {..} ProjectBuildContext {..}+                         buildOutcomes = do+    -- Update other build artefacts+    -- TODO: currently none, but could include:+    --        - bin symlinks/wrappers+    --        - haddock/hoogle/ctags indexes+    --        - delete stale lib registrations+    --        - delete stale package dirs++    postBuildStatus <- updatePostBuildProjectStatus+                         verbosity+                         distDirLayout+                         elaboratedPlanOriginal+                         pkgsBuildStatus+                         buildOutcomes++    -- Write the .ghc.environment file (if allowed by the env file write policy).+    let writeGhcEnvFilesPolicy =+          projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared+          $ projectConfig++        shouldWriteGhcEnvironment =+          case fromFlagOrDefault NeverWriteGhcEnvironmentFiles+               writeGhcEnvFilesPolicy+          of+            AlwaysWriteGhcEnvironmentFiles                -> True+            NeverWriteGhcEnvironmentFiles                 -> False+            WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->+              let compiler         = pkgConfigCompiler elaboratedShared+                  ghcCompatVersion = compilerCompatVersion GHC compiler+              in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion++    when shouldWriteGhcEnvironment $+      void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout)+                                     elaboratedPlanOriginal+                                     elaboratedShared+                                     postBuildStatus++    -- Finally if there were any build failures then report them and throw+    -- an exception to terminate the program+    dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes++    -- Note that it is a deliberate design choice that the 'buildTargets' is+    -- not passed to phase 1, and the various bits of input config is not+    -- passed to phase 2.+    --+    -- We make the install plan without looking at the particular targets the+    -- user asks us to build. The set of available things we can build is+    -- discovered from the env and config and is used to make the install plan.+    -- The targets just tell us which parts of the install plan to execute.+    --+    -- Conversely, executing the plan does not directly depend on any of the+    -- input config. The bits that are needed (or better, the decisions based+    -- on it) all go into the install plan.++    -- Notionally, the 'BuildFlags' should be things that do not affect what+    -- we build, just how we do it. These ones of course do+++------------------------------------------------------------------------------+-- Taking targets into account, selecting what to build+--++-- | The set of components to build, represented as a mapping from 'UnitId's+-- to the 'ComponentTarget's within the unit that will be selected+-- (e.g. selected to build, test or repl).+--+-- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that+-- matched this target. Typically this is exactly one, but in general it is+-- possible to for different selectors to match the same target. This extra+-- information is primarily to help make helpful error messages.+--+type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])]++-- | Given a set of 'TargetSelector's, resolve which 'UnitId's and+-- 'ComponentTarget's they ought to refer to.+--+-- The idea is that every user target identifies one or more roots in the+-- 'ElaboratedInstallPlan', which we will use to determine the closure+-- of what packages need to be built, dropping everything from the plan+-- that is unnecessary. This closure and pruning is done by+-- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms+-- of 'UnitId's and the 'ComponentTarget's within those.+--+-- This means we first need to translate the 'TargetSelector's into the+-- 'UnitId's and 'ComponentTarget's. This translation has to be different for+-- the different command line commands, like @build@, @repl@ etc. For example+-- the command @build pkgfoo@ could select a different set of components in+-- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and+-- all executables, whereas @repl@ would select the library or a single+-- executable. Furthermore, both of these examples could fail, and fail in+-- different ways and each needs to be able to produce helpful error messages.+--+-- So 'resolveTargets' takes two helpers: one to select the targets to be used+-- by user targets that refer to a whole package ('TargetPackage'), and+-- another to check user targets that refer to a component (or a module or+-- file within a component). These helpers can fail, and use their own error+-- type. Both helpers get given the 'AvailableTarget' info about the+-- component(s).+--+-- While commands vary quite a bit in their behaviour about which components to+-- select for a whole-package target, most commands have the same behaviour for+-- checking a user target that refers to a specific component. To help with+-- this commands can use 'selectComponentTargetBasic', either directly or as+-- a basis for their own @selectComponentTarget@ implementation.+--+resolveTargets :: forall err.+                  (forall k. TargetSelector+                          -> [AvailableTarget k]+                          -> Either (TargetProblem err) [k])+               -> (forall k. SubComponentTarget+                          -> AvailableTarget k+                          -> Either (TargetProblem err)  k )+               -> ElaboratedInstallPlan+               -> Maybe (SourcePackageDb)+               -> [TargetSelector]+               -> Either [TargetProblem err] TargetsMap+resolveTargets selectPackageTargets selectComponentTarget+               installPlan mPkgDb =+      fmap mkTargetsMap+    . either (Left . toList) Right+    . checkErrors+    . map (\ts -> (,) ts <$> checkTarget ts)+  where+    mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])]+                 -> TargetsMap+    mkTargetsMap targets =+        Map.map nubComponentTargets+      $ Map.fromListWith (++)+          [ (uid, [(ct, ts)])+          | (ts, cts) <- targets+          , (uid, ct) <- cts ]++    AvailableTargetIndexes{..} = availableTargetIndexes installPlan++    checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]++    -- We can ask to build any whole package, project-local or a dependency+    checkTarget bt@(TargetPackage _ [pkgid] mkfilter)+      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)+                  $ Map.lookup pkgid availableTargetsByPackageId+      = fmap (componentTargets WholeComponent)+      $ selectPackageTargets bt ats++      | otherwise+      = Left (TargetProblemNoSuchPackage pkgid)++    checkTarget (TargetPackage _ pkgids _)+      = error ("TODO: add support for multiple packages in a directory.  Got\n"+              ++ unlines (map prettyShow pkgids))+      -- For the moment this error cannot happen here, because it gets+      -- detected when the package config is being constructed. This case+      -- will need handling properly when we do add support.+      --+      -- TODO: how should this use case play together with the+      -- '--cabal-file' option of 'configure' which allows using multiple+      -- .cabal files for a single package?++    checkTarget bt@(TargetAllPackages mkfilter) =+        fmap (componentTargets WholeComponent)+      . selectPackageTargets bt+      . maybe id filterTargetsKind mkfilter+      . filter availableTargetLocalToProject+      $ concat (Map.elems availableTargetsByPackageId)++    checkTarget (TargetComponent pkgid cname subtarget)+      | Just ats <- Map.lookup (pkgid, cname)+                               availableTargetsByPackageIdAndComponentName+      = fmap (componentTargets subtarget)+      $ selectComponentTargets subtarget ats++      | Map.member pkgid availableTargetsByPackageId+      = Left (TargetProblemNoSuchComponent pkgid cname)++      | otherwise+      = Left (TargetProblemNoSuchPackage pkgid)++    checkTarget (TargetComponentUnknown pkgname ecname subtarget)+      | Just ats <- case ecname of+          Left ucname ->+            Map.lookup (pkgname, ucname)+                       availableTargetsByPackageNameAndUnqualComponentName+          Right cname ->+            Map.lookup (pkgname, cname)+                       availableTargetsByPackageNameAndComponentName+      = fmap (componentTargets subtarget)+      $ selectComponentTargets subtarget ats++      | Map.member pkgname availableTargetsByPackageName+      = Left (TargetProblemUnknownComponent pkgname ecname)++      | otherwise+      = Left (TargetNotInProject pkgname)++    checkTarget bt@(TargetPackageNamed pkgname mkfilter)+      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)+                  $ Map.lookup pkgname availableTargetsByPackageName+      = fmap (componentTargets WholeComponent)+      . selectPackageTargets bt+      $ ats++      | Just SourcePackageDb{ packageIndex } <- mPkgDb+      , let pkg = lookupPackageName packageIndex pkgname+      , not (null pkg)+      = Left (TargetAvailableInIndex pkgname)++      | otherwise+      = Left (TargetNotInProject pkgname)++    componentTargets :: SubComponentTarget+                     -> [(b, ComponentName)]+                     -> [(b, ComponentTarget)]+    componentTargets subtarget =+      map (fmap (\cname -> ComponentTarget cname subtarget))++    selectComponentTargets :: SubComponentTarget+                           -> [AvailableTarget k]+                           -> Either (TargetProblem err) [k]+    selectComponentTargets subtarget =+        either (Left . NE.head) Right+      . checkErrors+      . map (selectComponentTarget subtarget)++    checkErrors :: [Either e a] -> Either (NonEmpty e) [a]+    checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') })+                . partitionEithers+++data AvailableTargetIndexes = AvailableTargetIndexes {+       availableTargetsByPackageIdAndComponentName+         :: AvailableTargetsMap (PackageId, ComponentName),++       availableTargetsByPackageId+         :: AvailableTargetsMap PackageId,++       availableTargetsByPackageName+         :: AvailableTargetsMap PackageName,++       availableTargetsByPackageNameAndComponentName+         :: AvailableTargetsMap (PackageName, ComponentName),++       availableTargetsByPackageNameAndUnqualComponentName+         :: AvailableTargetsMap (PackageName, UnqualComponentName)+     }+type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]++-- We define a bunch of indexes to help 'resolveTargets' with resolving+-- 'TargetSelector's to specific 'UnitId's.+--+-- They are all derived from the 'availableTargets' index.+-- The 'availableTargetsByPackageIdAndComponentName' is just that main index,+-- while the others are derived by re-grouping on the index key.+--+-- They are all constructed lazily because they are not necessarily all used.+--+availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes+availableTargetIndexes installPlan = AvailableTargetIndexes{..}+  where+    availableTargetsByPackageIdAndComponentName =+      availableTargets installPlan++    availableTargetsByPackageId =+                  Map.mapKeysWith+                    (++) (\(pkgid, _cname) -> pkgid)+                    availableTargetsByPackageIdAndComponentName+      `Map.union` availableTargetsEmptyPackages++    availableTargetsByPackageName =+      Map.mapKeysWith+        (++) packageName+        availableTargetsByPackageId++    availableTargetsByPackageNameAndComponentName =+      Map.mapKeysWith+        (++) (\(pkgid, cname) -> (packageName pkgid, cname))+        availableTargetsByPackageIdAndComponentName++    availableTargetsByPackageNameAndUnqualComponentName =+      Map.mapKeysWith+        (++) (\(pkgid, cname) -> let pname  = packageName pkgid+                                     cname' = unqualComponentName pname cname+                                  in (pname, cname'))+        availableTargetsByPackageIdAndComponentName+     where+       unqualComponentName ::+         PackageName -> ComponentName -> UnqualComponentName+       unqualComponentName pkgname =+           fromMaybe (packageNameToUnqualComponentName pkgname)+         . componentNameString++    -- Add in all the empty packages. These do not appear in the+    -- availableTargetsByComponent map, since that only contains+    -- components, so packages with no components are invisible from+    -- that perspective.  The empty packages need to be there for+    -- proper error reporting, so users can select the empty package+    -- and then we can report that it is empty, otherwise we falsely+    -- report there is no such package at all.+    availableTargetsEmptyPackages =+      Map.fromList+        [ (packageId pkg, [])+        | InstallPlan.Configured pkg <- InstallPlan.toList installPlan+        , case elabPkgOrComp pkg of+            ElabComponent _ -> False+            ElabPackage   _ -> null (pkgComponents (elabPkgDescription pkg))+        ]++    --TODO: [research required] what if the solution has multiple+    --      versions of this package?+    --      e.g. due to setup deps or due to multiple independent sets+    --      of packages being built (e.g. ghc + ghcjs in a project)++filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]+filterTargetsKind ckind = filterTargetsKindWith (== ckind)++filterTargetsKindWith :: (ComponentKind -> Bool)+                     -> [AvailableTarget k] -> [AvailableTarget k]+filterTargetsKindWith p ts =+    [ t | t@(AvailableTarget _ cname _ _) <- ts+        , p (componentKind cname) ]++selectBuildableTargets :: [AvailableTarget k] -> [k]+selectBuildableTargets ts =+    [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]++selectBuildableTargetsWith :: (TargetRequested -> Bool)+                          -> [AvailableTarget k] -> [k]+selectBuildableTargetsWith p ts =+    [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]++selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])+selectBuildableTargets' ts =+    (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]+        [ forgetTargetDetail t+        | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ]++selectBuildableTargetsWith' :: (TargetRequested -> Bool)+                           -> [AvailableTarget k] -> ([k], [AvailableTarget ()])+selectBuildableTargetsWith' p ts =+    (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]+        [ forgetTargetDetail t+        | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ]+++forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()+forgetTargetDetail = fmap (const ())++forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]+forgetTargetsDetail = map forgetTargetDetail++-- | A basic @selectComponentTarget@ implementation to use or pass to+-- 'resolveTargets', that does the basic checks that the component is+-- buildable and isn't a test suite or benchmark that is disabled. This+-- can also be used to do these basic checks as part of a custom impl that+--+selectComponentTargetBasic :: SubComponentTarget+                           -> AvailableTarget k+                           -> Either (TargetProblem a) k+selectComponentTargetBasic subtarget+                           AvailableTarget {+                             availableTargetPackageId     = pkgid,+                             availableTargetComponentName = cname,+                             availableTargetStatus+                           } =+    case availableTargetStatus of+      TargetDisabledByUser ->+        Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget)++      TargetDisabledBySolver ->+        Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget)++      TargetNotLocal ->+        Left (TargetComponentNotProjectLocal pkgid cname subtarget)++      TargetNotBuildable ->+        Left (TargetComponentNotBuildable pkgid cname subtarget)++      TargetBuildable targetKey _ ->+        Right targetKey++-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts+-- for the extra unneeded info in the 'TargetsMap'.+--+pruneInstallPlanToTargets :: TargetAction -> TargetsMap+                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan+pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =+    assert (Map.size targetsMap > 0) $+    ProjectPlanning.pruneInstallPlanToTargets+      targetActionType+      (Map.map (map fst) targetsMap)+      elaboratedPlan++-- | Utility used by repl and run to check if the targets spans multiple+-- components, since those commands do not support multiple components.+--+distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName)+distinctTargetComponents targetsMap =+    Set.fromList [ (uid, cname)+                 | (uid, cts) <- Map.toList targetsMap+                 , (ComponentTarget cname _, _) <- cts ]+++------------------------------------------------------------------------------+-- Displaying what we plan to do+--++-- | Print a user-oriented presentation of the install plan, indicating what+-- will be built.+--+printPlan :: Verbosity+          -> ProjectBaseContext+          -> ProjectBuildContext+          -> IO ()+printPlan verbosity+          ProjectBaseContext {+            buildSettings = BuildTimeSettings{buildSettingDryRun},+            projectConfig = ProjectConfig {+              projectConfigLocalPackages =+                  PackageConfig {packageConfigOptimization}+            }+          }+          ProjectBuildContext {+            elaboratedPlanToExecute = elaboratedPlan,+            elaboratedShared,+            pkgsBuildStatus+          }++  | null pkgs+  = notice verbosity "Up to date"++  | otherwise+  = noticeNoWrap verbosity $ unlines $+      (showBuildProfile ++ "In order, the following "+       ++ wouldWill ++ " be built"+       ++ ifNormal " (use -v for more details)" ++ ":")+    : map showPkgAndReason pkgs++  where+    pkgs = InstallPlan.executionOrder elaboratedPlan++    ifVerbose s | verbosity >= verbose = s+                | otherwise            = ""++    ifNormal s | verbosity >= verbose = ""+               | otherwise            = s++    wouldWill | buildSettingDryRun = "would"+              | otherwise          = "will"++    showPkgAndReason :: ElaboratedReadyPackage -> String+    showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $+      [ " -"+      , if verbosity >= deafening+        then prettyShow (installedUnitId elab)+        else prettyShow (packageId elab)+      , case elabPkgOrComp elab of+          ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg))+          ElabComponent comp ->+            "(" ++ showComp elab comp ++ ")"+      , showFlagAssignment (nonDefaultFlags elab)+      , showConfigureFlags elab+      , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab+        in "(" ++ showBuildStatus buildStatus ++ ")"+      ]++    showComp elab comp =+        maybe "custom" prettyShow (compComponentName comp) +++        if Map.null (elabInstantiatedWith elab)+            then ""+            else " with " +++                intercalate ", "+                    -- TODO: Abbreviate the UnitIds+                    [ prettyShow k ++ "=" ++ prettyShow v+                    | (k,v) <- Map.toList (elabInstantiatedWith elab) ]++    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment+    nonDefaultFlags elab =+      elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab++    showTargets elab+      | null (elabBuildTargets elab) = ""+      | otherwise+      = "("+        ++ intercalate ", " [ showComponentTarget (packageId elab) t+                            | t <- elabBuildTargets elab ]+        ++ ")"++    showConfigureFlags elab =+        let fullConfigureFlags+              = setupHsConfigureFlags+                    (ReadyPackage elab)+                    elaboratedShared+                    verbosity+                    "$builddir"+            -- | Given a default value @x@ for a flag, nub @Flag x@+            -- into @NoFlag@.  This gives us a tidier command line+            -- rendering.+            nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a+            nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag+            nubFlag _ f                         = f++            (tryLibProfiling, tryExeProfiling) =+              computeEffectiveProfiling fullConfigureFlags++            partialConfigureFlags+              = mempty {+                configProf    =+                    nubFlag False (configProf fullConfigureFlags),+                configProfExe =+                    nubFlag tryExeProfiling (configProfExe fullConfigureFlags),+                configProfLib =+                    nubFlag tryLibProfiling (configProfLib fullConfigureFlags)+                -- Maybe there are more we can add+              }+        -- Not necessary to "escape" it, it's just for user output+        in unwords . ("":) $+            commandShowOptions+            (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))+            partialConfigureFlags++    showBuildStatus status = case status of+      BuildStatusPreExisting -> "existing package"+      BuildStatusInstalled   -> "already installed"+      BuildStatusDownload {} -> "requires download & build"+      BuildStatusUnpack   {} -> "requires build"+      BuildStatusRebuild _ rebuild -> case rebuild of+        BuildStatusConfigure+          (MonitoredValueChanged _)   -> "configuration changed"+        BuildStatusConfigure mreason  -> showMonitorChangedReason mreason+        BuildStatusBuild _ buildreason -> case buildreason of+          BuildReasonDepsRebuilt      -> "dependency rebuilt"+          BuildReasonFilesChanged+            mreason                   -> showMonitorChangedReason mreason+          BuildReasonExtraTargets _   -> "additional components to build"+          BuildReasonEphemeralTargets -> "ephemeral targets"+      BuildStatusUpToDate {} -> "up to date" -- doesn't happen++    showMonitorChangedReason (MonitoredFileChanged file) =+      "file " ++ file ++ " changed"+    showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"+    showMonitorChangedReason  MonitorFirstRun            = "first run"+    showMonitorChangedReason  MonitorCorruptCache        =+      "cannot read state cache"++    showBuildProfile = "Build profile: " ++ unwords [+      "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,+      "-O" ++  (case packageConfigOptimization of+                Setup.Flag NoOptimisation      -> "0"+                Setup.Flag NormalOptimisation  -> "1"+                Setup.Flag MaximumOptimisation -> "2"+                Setup.NoFlag                   -> "1")]+      ++ "\n"++-- | If there are build failures then report them and throw an exception.+--+dieOnBuildFailures :: Verbosity -> CurrentCommand+                   -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()+dieOnBuildFailures verbosity currentCommand plan buildOutcomes+  | null failures = return ()++  | isSimpleCase  = exitFailure++  | otherwise = do+      -- For failures where we have a build log, print the log plus a header+       sequence_+         [ do notice verbosity $+                '\n' : renderFailureDetail False pkg reason+                    ++ "\nBuild log ( " ++ logfile ++ " ):"+              readFile logfile >>= noticeNoWrap verbosity+         | (pkg, ShowBuildSummaryAndLog reason logfile)+             <- failuresClassification+         ]++       -- For all failures, print either a short summary (if we showed the+       -- build log) or all details+       dieIfNotHaddockFailure verbosity $ unlines+         [ case failureClassification of+             ShowBuildSummaryAndLog reason _+               | verbosity > normal+              -> renderFailureDetail mentionDepOf pkg reason++               | otherwise+              -> renderFailureSummary mentionDepOf pkg reason+              ++ ". See the build log above for details."++             ShowBuildSummaryOnly reason ->+               renderFailureDetail mentionDepOf pkg reason++         | let mentionDepOf = verbosity <= normal+         , (pkg, failureClassification) <- failuresClassification ]+  where+    failures =  [ (pkgid, failure)+                | (pkgid, Left failure) <- Map.toList buildOutcomes ]++    failuresClassification =+      [ (pkg, classifyBuildFailure failure)+      | (pkgid, failure) <- failures+      , case buildFailureReason failure of+          DependentFailed {} -> verbosity > normal+          _                  -> True+      , InstallPlan.Configured pkg <-+           maybeToList (InstallPlan.lookup plan pkgid)+      ]++    dieIfNotHaddockFailure+      | currentCommand == HaddockCommand            = die'+      | all isHaddockFailure failuresClassification = warn+      | otherwise                                   = die'+      where+        isHaddockFailure+          (_, ShowBuildSummaryOnly   (HaddocksFailed _)  ) = True+        isHaddockFailure+          (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True+        isHaddockFailure+          _                                                = False+++    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation+    classifyBuildFailure BuildFailure {+                           buildFailureReason  = reason,+                           buildFailureLogFile = mlogfile+                         } =+      maybe (ShowBuildSummaryOnly   reason)+            (ShowBuildSummaryAndLog reason) $ do+        logfile <- mlogfile+        e       <- buildFailureException reason+        ExitFailure 1 <- fromException e+        return logfile++    -- Special case: we don't want to report anything complicated in the case+    -- of just doing build on the current package, since it's clear from+    -- context which package failed.+    --+    -- We generalise this rule as follows:+    --  - if only one failure occurs, and it is in a single root+    --    package (i.e. a package with nothing else depending on it)+    --  - and that failure is of a kind that always reports enough+    --    detail itself (e.g. ghc reporting errors on stdout)+    --  - then we do not report additional error detail or context.+    --+    isSimpleCase+      | [(pkgid, failure)] <- failures+      , [pkg]              <- rootpkgs+      , installedUnitId pkg == pkgid+      , isFailureSelfExplanatory (buildFailureReason failure)+      , currentCommand /= InstallCommand+      = True+      | otherwise+      = False++    -- NB: if the Setup script segfaulted or was interrupted,+    -- we should give more detailed information.  So only+    -- assume that exit code 1 is "pedestrian failure."+    isFailureSelfExplanatory (BuildFailed e)+      | Just (ExitFailure 1) <- fromException e = True++    isFailureSelfExplanatory (ConfigureFailed e)+      | Just (ExitFailure 1) <- fromException e = True++    isFailureSelfExplanatory _                  = False++    rootpkgs =+      [ pkg+      | InstallPlan.Configured pkg <- InstallPlan.toList plan+      , hasNoDependents pkg ]++    ultimateDeps pkgid =+        filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)+               (InstallPlan.reverseDependencyClosure plan [pkgid])++    hasNoDependents :: HasUnitId pkg => pkg -> Bool+    hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId++    renderFailureDetail mentionDepOf pkg reason =+        renderFailureSummary mentionDepOf pkg reason ++ "."+     ++ renderFailureExtraDetail reason+     ++ maybe "" showException (buildFailureException reason)++    renderFailureSummary mentionDepOf pkg reason =+        case reason of+          DownloadFailed  _ -> "Failed to download " ++ pkgstr+          UnpackFailed    _ -> "Failed to unpack "   ++ pkgstr+          ConfigureFailed _ -> "Failed to build "    ++ pkgstr+          BuildFailed     _ -> "Failed to build "    ++ pkgstr+          ReplFailed      _ -> "repl failed for "    ++ pkgstr+          HaddocksFailed  _ -> "Failed to build documentation for " ++ pkgstr+          TestsFailed     _ -> "Tests failed for " ++ pkgstr+          BenchFailed     _ -> "Benchmarks failed for " ++ pkgstr+          InstallFailed   _ -> "Failed to build "  ++ pkgstr+          DependentFailed depid+                            -> "Failed to build " ++ prettyShow (packageId pkg)+                            ++ " because it depends on " ++ prettyShow depid+                            ++ " which itself failed to build"+      where+        pkgstr = elabConfiguredName verbosity pkg+              ++ if mentionDepOf+                   then renderDependencyOf (installedUnitId pkg)+                   else ""++    renderFailureExtraDetail (ConfigureFailed _) =+      " The failure occurred during the configure step."+    renderFailureExtraDetail (InstallFailed   _) =+      " The failure occurred during the final install step."+    renderFailureExtraDetail _                   =+      ""++    renderDependencyOf pkgid =+      case ultimateDeps pkgid of+        []         -> ""+        (p1:[])    ->+          " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"+        (p1:p2:[]) ->+          " (which is required by " ++ elabPlanPackageName verbosity p1+          ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")"+        (p1:p2:_)  ->+          " (which is required by " ++ elabPlanPackageName verbosity p1+          ++ ", " ++ elabPlanPackageName verbosity p2+          ++ " and others)"++    showException e = case fromException e of+      Just (ExitFailure 1) -> ""++#ifdef MIN_VERSION_unix+      -- Note [Positive "signal" exit code]+      -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+      -- What's the business with the test for negative and positive+      -- signal values?  The API for process specifies that if the+      -- process died due to a signal, it returns a *negative* exit+      -- code.  So that's the negative test.+      --+      -- What about the positive test?  Well, when we find out that+      -- a process died due to a signal, we ourselves exit with that+      -- exit code.  However, we don't "kill ourselves" with the+      -- signal; we just exit with the same code as the signal: thus+      -- the caller sees a *positive* exit code.  So that's what+      -- happens when we get a positive exit code.+      Just (ExitFailure n)+        | -n == fromIntegral sigSEGV ->+            " The build process segfaulted (i.e. SIGSEGV)."++        |  n == fromIntegral sigSEGV ->+            " The build process terminated with exit code " ++ show n+         ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."++        | -n == fromIntegral sigKILL ->+            " The build process was killed (i.e. SIGKILL). " ++ explanation++        |  n == fromIntegral sigKILL ->+            " The build process terminated with exit code " ++ show n+         ++ " which may be because some part of it was killed "+         ++ "(i.e. SIGKILL). " ++ explanation+        where+          explanation =+            "The typical reason for this is that there is not "+            ++ "enough memory available (e.g. the OS killed a process "+            ++ "using lots of memory)."+#endif+      Just (ExitFailure n) ->+        " The build process terminated with exit code " ++ show n++      _ -> " The exception was:\n  "+#if MIN_VERSION_base(4,8,0)+             ++ displayException e+#else+             ++ show e+#endif++    buildFailureException reason =+      case reason of+        DownloadFailed  e -> Just e+        UnpackFailed    e -> Just e+        ConfigureFailed e -> Just e+        BuildFailed     e -> Just e+        ReplFailed      e -> Just e+        HaddocksFailed  e -> Just e+        TestsFailed     e -> Just e+        BenchFailed     e -> Just e+        InstallFailed   e -> Just e+        DependentFailed _ -> Nothing++data BuildFailurePresentation =+       ShowBuildSummaryOnly   BuildFailureReason+     | ShowBuildSummaryAndLog BuildFailureReason FilePath++-------------------------------------------------------------------------------+-- Dummy projects+-------------------------------------------------------------------------------++-- | Create a dummy project context, without a .cabal or a .cabal.project file+-- (a place where to put a temporary dist directory is still needed)+establishDummyProjectBaseContext+  :: Verbosity+  -> ProjectConfig+  -> DistDirLayout+     -- ^ Where to put the dist directory+  -> [PackageSpecifier UnresolvedSourcePackage]+     -- ^ The packages to be included in the project+  -> CurrentCommand+  -> IO ProjectBaseContext+establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do+    cabalDir <- getCabalDir++    globalConfig <- runRebuild ""+                  $ readGlobalConfig verbosity+                  $ projectConfigConfigFile+                  $ projectConfigShared cliConfig+    let projectConfig = globalConfig <> cliConfig++    let ProjectConfigBuildOnly {+          projectConfigLogsDir+        } = projectConfigBuildOnly projectConfig++        ProjectConfigShared {+          projectConfigStoreDir+        } = projectConfigShared projectConfig++        mlogsDir = flagToMaybe projectConfigLogsDir+        mstoreDir = flagToMaybe projectConfigStoreDir+        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir++        buildSettings = resolveBuildTimeSettings+                          verbosity cabalDirLayout+                          projectConfig++    return ProjectBaseContext {+      distDirLayout,+      cabalDirLayout,+      projectConfig,+      localPackages,+      buildSettings,+      currentCommand+    }++establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout+establishDummyDistDirLayout verbosity cliConfig tmpDir = do+    let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory++    -- Create the dist directories+    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout+    createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout++    return distDirLayout+  where+    mdistDirectory = flagToMaybe+                   $ projectConfigDistDir+                   $ projectConfigShared cliConfig+    projectRoot = ProjectRootImplicit tmpDir
+ src/Distribution/Client/ProjectPlanOutput.hs view
@@ -0,0 +1,939 @@+{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,+             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,+             ScopedTypeVariables #-}++module Distribution.Client.ProjectPlanOutput (+    -- * Plan output+    writePlanExternalRepresentation,++    -- * Project status+    -- | Several outputs rely on having a general overview of+    PostBuildProjectStatus(..),+    updatePostBuildProjectStatus,+    createPackageEnvironment,+    writePlanGhcEnvironment,+    argsEquivalentOfGhcEnvironmentFile,+  ) where++import           Distribution.Client.ProjectPlanning.Types+import           Distribution.Client.ProjectBuilding.Types+import           Distribution.Client.DistDirLayout+import           Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..))+import           Distribution.Client.Types.PackageLocation (PackageLocation(..))+import           Distribution.Client.Types.ConfiguredId (confInstId)+import           Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))+import           Distribution.Client.HashValue (showHashValue, hashValue)+import           Distribution.Client.Utils (cabalInstallVersion)++import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.Utils.Json as J+import qualified Distribution.Simple.InstallDirs as InstallDirs++import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps++import           Distribution.Package+import           Distribution.System+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import qualified Distribution.PackageDescription as PD+import           Distribution.Compiler (CompilerFlavor(GHC, GHCJS))+import           Distribution.Simple.Compiler+                   ( PackageDBStack, PackageDB(..)+                   , compilerVersion, compilerFlavor, showCompilerId+                   , compilerId, CompilerId(..), Compiler )+import           Distribution.Simple.GHC+                   ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)+                   , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile+                   , writeGhcEnvironmentFile )+import           Distribution.Simple.BuildPaths+                   ( dllExtension, exeExtension )+import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph (Graph, Node)+import qualified Distribution.Compat.Binary as Binary+import           Distribution.Simple.Utils+import           Distribution.Verbosity++import Prelude ()+import Distribution.Client.Compat.Prelude++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Builder as BB++import           System.FilePath+import           System.IO++import Distribution.Simple.Program.GHC (packageDbArgsDb)++-----------------------------------------------------------------------------+-- Writing plan.json files+--++-- | Write out a representation of the elaborated install plan.+--+-- This is for the benefit of debugging and external tools like editors.+--+writePlanExternalRepresentation :: DistDirLayout+                                -> ElaboratedInstallPlan+                                -> ElaboratedSharedConfig+                                -> IO ()+writePlanExternalRepresentation distDirLayout elaboratedInstallPlan+                                elaboratedSharedConfig =+    writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $+        BB.toLazyByteString+      . J.encodeToBuilder+      $ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig++-- | Renders a subset of the elaborated install plan in a semi-stable JSON+-- format.+--+encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value+encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =+    --TODO: [nice to have] include all of the sharedPackageConfig and all of+    --      the parts of the elaboratedInstallPlan+    J.object [ "cabal-version"     J..= jdisplay cabalInstallVersion+             , "cabal-lib-version" J..= jdisplay cabalVersion+             , "compiler-id"       J..= (J.String . showCompilerId . pkgConfigCompiler)+                                        elaboratedSharedConfig+             , "os"                J..= jdisplay os+             , "arch"              J..= jdisplay arch+             , "install-plan"      J..= installPlanToJ elaboratedInstallPlan+             ]+  where+    plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig++    installPlanToJ :: ElaboratedInstallPlan -> [J.Value]+    installPlanToJ = map planPackageToJ . InstallPlan.toList++    planPackageToJ :: ElaboratedPlanPackage -> J.Value+    planPackageToJ pkg =+      case pkg of+        InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi+        InstallPlan.Configured elab -> elaboratedPackageToJ False elab+        InstallPlan.Installed  elab -> elaboratedPackageToJ True  elab+        -- Note that the plan.json currently only uses the elaborated plan,+        -- not the improved plan. So we will not get the Installed state for+        -- that case, but the code supports it in case we want to use this+        -- later in some use case where we want the status of the build.++    installedPackageInfoToJ :: InstalledPackageInfo -> J.Value+    installedPackageInfoToJ ipi =+      -- Pre-existing packages lack configuration information such as their flag+      -- settings or non-lib components. We only get pre-existing packages for+      -- the global/core packages however, so this isn't generally a problem.+      -- So these packages are never local to the project.+      --+      J.object+        [ "type"       J..= J.String "pre-existing"+        , "id"         J..= (jdisplay . installedUnitId) ipi+        , "pkg-name"   J..= (jdisplay . pkgName . packageId) ipi+        , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi+        , "depends"    J..= map jdisplay (installedDepends ipi)+        ]++    elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value+    elaboratedPackageToJ isInstalled elab =+      J.object $+        [ "type"       J..= J.String (if isInstalled then "installed"+                                                     else "configured")+        , "id"         J..= (jdisplay . installedUnitId) elab+        , "pkg-name"   J..= (jdisplay . pkgName . packageId) elab+        , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab+        , "flags"      J..= J.object [ PD.unFlagName fn J..= v+                                     | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ]+        , "style"      J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))+        , "pkg-src"    J..= packageLocationToJ (elabPkgSourceLocation elab)+        ] +++        [ "pkg-cabal-sha256" J..= J.String (showHashValue hash)+        | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] +++        [ "pkg-src-sha256" J..= J.String (showHashValue hash)+        | Just hash <- [elabPkgSourceHash elab] ] +++        (case elabBuildStyle elab of+            BuildInplaceOnly ->+                ["dist-dir"   J..= J.String dist_dir]+            BuildAndInstall ->+                -- TODO: install dirs?+                []+            ) +++        case elabPkgOrComp elab of+          ElabPackage pkg ->+            let components = J.object $+                  [ comp2str c J..= (J.object $+                    [ "depends"     J..= map (jdisplay . confInstId) ldeps+                    , "exe-depends" J..= map (jdisplay . confInstId) edeps+                    ] +++                    bin_file c)+                  | (c,(ldeps,edeps))+                      <- ComponentDeps.toList $+                         ComponentDeps.zip (pkgLibDependencies pkg)+                                           (pkgExeDependencies pkg) ]+            in ["components" J..= components]+          ElabComponent comp ->+            ["depends"     J..= map (jdisplay . confInstId) (elabLibDependencies elab)+            ,"exe-depends" J..= map jdisplay (elabExeDependencies elab)+            ,"component-name" J..= J.String (comp2str (compSolverName comp))+            ] +++            bin_file (compSolverName comp)+     where+      packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value+      packageLocationToJ pkgloc =+        case pkgloc of+          LocalUnpackedPackage local ->+            J.object [ "type" J..= J.String "local"+                     , "path" J..= J.String local+                     ]+          LocalTarballPackage local ->+            J.object [ "type" J..= J.String "local-tar"+                     , "path" J..= J.String local+                     ]+          RemoteTarballPackage uri _ ->+            J.object [ "type" J..= J.String "remote-tar"+                     , "uri"  J..= J.String (show uri)+                     ]+          RepoTarballPackage repo _ _ ->+            J.object [ "type" J..= J.String "repo-tar"+                     , "repo" J..= repoToJ repo+                     ]+          RemoteSourceRepoPackage srcRepo _ ->+            J.object [ "type" J..= J.String "source-repo"+                     , "source-repo" J..= sourceRepoToJ srcRepo+                     ]++      repoToJ :: Repo -> J.Value+      repoToJ repo =+        case repo of+          RepoLocalNoIndex{..} ->+            J.object [ "type" J..= J.String "local-repo-no-index"+                     , "path" J..= J.String repoLocalDir+                     ]+          RepoRemote{..} ->+            J.object [ "type" J..= J.String "remote-repo"+                     , "uri"  J..= J.String (show (remoteRepoURI repoRemote))+                     ]+          RepoSecure{..} ->+            J.object [ "type" J..= J.String "secure-repo"+                     , "uri"  J..= J.String (show (remoteRepoURI repoRemote))+                     ]++      sourceRepoToJ :: SourceRepoMaybe -> J.Value+      sourceRepoToJ SourceRepositoryPackage{..} =+        J.object $ filter ((/= J.Null) . snd) $+          [ "type"     J..= jdisplay srpType+          , "location" J..= J.String srpLocation+          , "branch"   J..= fmap J.String srpBranch+          , "tag"      J..= fmap J.String srpTag+          , "subdir"   J..= fmap J.String srpSubdir+          ]++      dist_dir = distBuildDirectory distDirLayout+                    (elabDistDirParams elaboratedSharedConfig elab)++      bin_file c = case c of+        ComponentDeps.ComponentExe s   -> bin_file' s+        ComponentDeps.ComponentTest s  -> bin_file' s+        ComponentDeps.ComponentBench s -> bin_file' s+        ComponentDeps.ComponentFLib s  -> flib_file' s+        _ -> []+      bin_file' s =+        ["bin-file" J..= J.String bin]+       where+        bin = if elabBuildStyle elab == BuildInplaceOnly+               then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat+               else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat++      flib_file' s =+        ["bin-file" J..= J.String bin]+       where+        bin = if elabBuildStyle elab == BuildInplaceOnly+               then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat+               else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat++    comp2str :: ComponentDeps.Component -> String+    comp2str = prettyShow++    style2str :: Bool -> BuildStyle -> String+    style2str True  _                = "local"+    style2str False BuildInplaceOnly = "inplace"+    style2str False BuildAndInstall  = "global"++    jdisplay :: Pretty a => a -> J.Value+    jdisplay = J.String . prettyShow+++-----------------------------------------------------------------------------+-- Project status+--++-- So, what is the status of a project after a build? That is, how do the+-- inputs (package source files etc) compare to the output artefacts (build+-- libs, exes etc)? Do the outputs reflect the current values of the inputs+-- or are outputs out of date or invalid?+--+-- First of all, what do we mean by out-of-date and what do we mean by+-- invalid? We think of the build system as a morally pure function that+-- computes the output artefacts given input values. We say an output artefact+-- is out of date when its value is not the value that would be computed by a+-- build given the current values of the inputs. An output artefact can be+-- out-of-date but still be perfectly usable; it simply correspond to a+-- previous state of the inputs.+--+-- On the other hand there are cases where output artefacts cannot safely be+-- used. For example libraries and dynamically linked executables cannot be+-- used when the libs they depend on change without them being recompiled+-- themselves. Whether an artefact is still usable depends on what it is, e.g.+-- dynamically linked vs statically linked and on how it gets updated (e.g.+-- only atomically on success or if failure can leave invalid states). We need+-- a definition (or two) that is independent of the kind of artefact and can+-- be computed just in terms of changes in package graphs, but are still+-- useful for determining when particular kinds of artefacts are invalid.+--+-- Note that when we talk about packages in this context we just mean nodes+-- in the elaborated install plan, which can be components or packages.+--+-- There's obviously a close connection between packages being out of date and+-- their output artefacts being unusable: most of the time if a package+-- remains out of date at the end of a build then some of its output artefacts+-- will be unusable. That is true most of the time because a build will have+-- attempted to build one of the out-of-date package's dependencies. If the+-- build of the dependency succeeded then it changed output artefacts (like+-- libs) and if it failed then it may have failed after already changing+-- things (think failure after updating some but not all .hi files).+--+-- There are a few reasons we may end up with still-usable output artefacts+-- for a package even when it remains out of date at the end of a build.+-- Firstly if executing a plan fails then packages can be skipped, and thus we+-- may have packages where all their dependencies were skipped. Secondly we+-- have artefacts like statically linked executables which are not affected by+-- libs they depend on being recompiled. Furthermore, packages can be out of+-- date due to changes in build tools or Setup.hs scripts they depend on, but+-- again libraries or executables in those out-of-date packages remain usable.+--+-- So we have two useful definitions of invalid. Both are useful, for+-- different purposes, so we will compute both. The first corresponds to the+-- invalid libraries and dynamic executables. We say a package is invalid by+-- changed deps if any of the packages it depends on (via library dep edges)+-- were rebuilt (successfully or unsuccessfully). The second definition+-- corresponds to invalid static executables. We say a package is invalid by+-- a failed build simply if the package was built but unsuccessfully.+--+-- So how do we find out what packages are out of date or invalid?+--+-- Obviously we know something for all the packages that were part of the plan+-- that was executed, but that is just a subset since we prune the plan down+-- to the targets and their dependencies.+--+-- Recall the steps we go though:+--+-- + starting with the initial improved plan (this is the full project);+--+-- + prune the plan to the user's build targets;+--+-- + rebuildTargetsDryRun on the pruned plan giving us a BuildStatusMap+--   covering the pruned subset of the original plan;+--+-- + execute the plan giving us BuildOutcomes which tell us success/failure+--   for each package.+--+-- So given that the BuildStatusMap and BuildOutcomes do not cover everything+-- in the original plan, what can they tell us about the original plan?+--+-- The BuildStatusMap tells us directly that some packages are up to date and+-- others out of date (but only for the pruned subset). But we know that+-- everything that is a reverse dependency of an out-of-date package is itself+-- out-of-date (whether or not it is in the pruned subset). Of course after+-- a build the BuildOutcomes may tell us that some of those out-of-date+-- packages are now up to date (ie a successful build outcome).+--+-- The difference is packages that are reverse dependencies of out-of-date+-- packages but are not brought up-to-date by the build (i.e. did not have+-- successful outcomes, either because they failed or were not in the pruned+-- subset to be built). We also know which packages were rebuilt, so we can+-- use this to find the now-invalid packages.+--+-- Note that there are still packages for which we cannot discover full status+-- information. There may be packages outside of the pruned plan that do not+-- depend on packages within the pruned plan that were discovered to be+-- out-of-date. For these packages we do not know if their build artefacts+-- are out-of-date or not. We do know however that they are not invalid, as+-- that's not possible given our definition of invalid. Intuitively it is+-- because we have not disturbed anything that these packages depend on, e.g.+-- we've not rebuilt any libs they depend on. Recall that our widest+-- definition of invalid was only concerned about dependencies on libraries+-- (to cover problems like shared libs or GHC seeing inconsistent .hi files).+--+-- So our algorithm for out-of-date packages is relatively simple: take the+-- reverse dependency closure in the original improved plan (pre-pruning) of+-- the out-of-date packages (as determined by the BuildStatusMap from the dry+-- run). That gives a set of packages that were definitely out of date after+-- the dry run. Now we remove from this set the packages that the+-- BuildOutcomes tells us are now up-to-date after the build. The remaining+-- set is the out-of-date packages.+--+-- As for packages that are invalid by changed deps, we start with the plan+-- dependency graph but keep only those edges that point to libraries (so+-- ignoring deps on exes and setup scripts). We take the packages for which a+-- build was attempted (successfully or unsuccessfully, but not counting+-- knock-on failures) and take the reverse dependency closure. We delete from+-- this set all the packages that were built successfully. Note that we do not+-- need to intersect with the out-of-date packages since this follows+-- automatically: all rev deps of packages we attempted to build must have+-- been out of date at the start of the build, and if they were not built+-- successfully then they're still out of date -- meeting our definition of+-- invalid.+++type PackageIdSet     = Set UnitId+type PackagesUpToDate = PackageIdSet++data PostBuildProjectStatus = PostBuildProjectStatus {++       -- | Packages that are known to be up to date. These were found to be+       -- up to date before the build, or they have a successful build outcome+       -- afterwards.+       --+       -- This does not include any packages outside of the subset of the plan+       -- that was executed because we did not check those and so don't know+       -- for sure that they're still up to date.+       --+       packagesDefinitelyUpToDate :: PackageIdSet,++       -- | Packages that are probably still up to date (and at least not+       -- known to be out of date, and certainly not invalid). This includes+       -- 'packagesDefinitelyUpToDate' plus packages that were up to date+       -- previously and are outside of the subset of the plan that was+       -- executed. It excludes 'packagesOutOfDate'.+       --+       packagesProbablyUpToDate :: PackageIdSet,++       -- | Packages that are known to be out of date. These are packages+       -- that were determined to be out of date before the build, and they+       -- do not have a successful build outcome afterwards.+       --+       -- Note that this can sometimes include packages outside of the subset+       -- of the plan that was executed. For example suppose package A and B+       -- depend on C, and A is the target so only A and C are in the subset+       -- to be built. Now suppose C is found to have changed, then both A+       -- and B are out-of-date before the build and since B is outside the+       -- subset to be built then it will remain out of date.+       --+       -- Note also that this is /not/ the inverse of+       -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'.+       -- There are packages where we have no information (ones that were not+       -- in the subset of the plan that was executed).+       --+       packagesOutOfDate :: PackageIdSet,++       -- | Packages that depend on libraries that have changed during the+       -- build (either build success or failure).+       --+       -- This corresponds to the fact that libraries and dynamic executables+       -- are invalid once any of the libs they depend on change.+       --+       -- This does include packages that themselves failed (i.e. it is a+       -- superset of 'packagesInvalidByFailedBuild'). It does not include+       -- changes in dependencies on executables (i.e. build tools).+       --+       packagesInvalidByChangedLibDeps :: PackageIdSet,++       -- | Packages that themselves failed during the build (i.e. them+       -- directly not a dep).+       --+       -- This corresponds to the fact that static executables are invalid+       -- in unlucky circumstances such as linking failing half way though,+       -- or data file generation failing.+       --+       -- This is a subset of 'packagesInvalidByChangedLibDeps'.+       --+       packagesInvalidByFailedBuild :: PackageIdSet,++       -- | A subset of the plan graph, including only dependency-on-library+       -- edges. That is, dependencies /on/ libraries, not dependencies /of/+       -- libraries. This tells us all the libraries that packages link to.+       --+       -- This is here as a convenience, as strictly speaking it's not status+       -- as it's just a function of the original 'ElaboratedInstallPlan'.+       --+       packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage),++       -- | As a convenience for 'Set.intersection' with any of the other+       -- 'PackageIdSet's to select only packages that are part of the+       -- project locally (i.e. with a local source dir).+       --+       packagesBuildLocal     :: PackageIdSet,++       -- | As a convenience for 'Set.intersection' with any of the other+       -- 'PackageIdSet's to select only packages that are being built+       -- in-place within the project (i.e. not destined for the store).+       --+       packagesBuildInplace   :: PackageIdSet,++       -- | As a convenience for 'Set.intersection' or 'Set.difference' with+       -- any of the other 'PackageIdSet's to select only packages that were+       -- pre-installed or already in the store prior to the build.+       --+       packagesAlreadyInStore :: PackageIdSet+     }++-- | Work out which packages are out of date or invalid after a build.+--+postBuildProjectStatus :: ElaboratedInstallPlan+                       -> PackagesUpToDate+                       -> BuildStatusMap+                       -> BuildOutcomes+                       -> PostBuildProjectStatus+postBuildProjectStatus plan previousPackagesUpToDate+                       pkgBuildStatus buildOutcomes =+    PostBuildProjectStatus {+      packagesDefinitelyUpToDate,+      packagesProbablyUpToDate,+      packagesOutOfDate,+      packagesInvalidByChangedLibDeps,+      packagesInvalidByFailedBuild,+      -- convenience stuff+      packagesLibDepGraph,+      packagesBuildLocal,+      packagesBuildInplace,+      packagesAlreadyInStore+    }+  where+    packagesDefinitelyUpToDate =+       packagesUpToDatePreBuild+        `Set.union`+       packagesSuccessfulPostBuild++    packagesProbablyUpToDate =+      packagesDefinitelyUpToDate+        `Set.union`+      (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild)++    packagesOutOfDate =+      packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild++    packagesInvalidByChangedLibDeps =+      packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild++    packagesInvalidByFailedBuild =+      packagesFailurePostBuild++    -- Note: if any of the intermediate values below turn out to be useful in+    -- their own right then we can simply promote them to the result record++    -- The previous set of up-to-date packages will contain bogus package ids+    -- when the solver plan or config contributing to the hash changes.+    -- So keep only the ones where the package id (i.e. hash) is the same.+    previousPackagesUpToDate' =+      Set.intersection+        previousPackagesUpToDate+        (InstallPlan.keysSet plan)++    packagesUpToDatePreBuild =+      Set.filter+        (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid))+        -- For packages not in the plan subset we did the dry-run on we don't+        -- know anything about their status, so not known to be /up to date/.+        (InstallPlan.keysSet plan)++    packagesOutOfDatePreBuild =+      Set.fromList . map installedUnitId $+      InstallPlan.reverseDependencyClosure plan+        [ ipkgid+        | pkg <- InstallPlan.toList plan+        , let ipkgid = installedUnitId pkg+        , lookupBuildStatusRequiresBuild False ipkgid+        -- For packages not in the plan subset we did the dry-run on we don't+        -- know anything about their status, so not known to be /out of date/.+        ]++    packagesSuccessfulPostBuild =+      Set.fromList+        [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ]++    -- direct failures, not failures due to deps+    packagesFailurePostBuild =+      Set.fromList+        [ ikgid+        | (ikgid, Left failure) <- Map.toList buildOutcomes+        , case buildFailureReason failure of+            DependentFailed _ -> False+            _                 -> True+        ]++    -- Packages that have a library dependency on a package for which a build+    -- was attempted+    packagesDepOnChangedLib =+      Set.fromList . map Graph.nodeKey $+      fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $+      Graph.revClosure packagesLibDepGraph+        ( Map.keys+        . Map.filter (uncurry buildAttempted)+        $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes+        )++    -- The plan graph but only counting dependency-on-library edges+    packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)+    packagesLibDepGraph =+      Graph.fromDistinctList+        [ Graph.N pkg (installedUnitId pkg) libdeps+        | pkg <- InstallPlan.toList plan+        , let libdeps = case pkg of+                InstallPlan.PreExisting ipkg  -> installedDepends ipkg+                InstallPlan.Configured srcpkg -> elabLibDeps srcpkg+                InstallPlan.Installed  srcpkg -> elabLibDeps srcpkg+        ]+    elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies++    -- Was a build was attempted for this package?+    -- If it doesn't have both a build status and outcome then the answer is no.+    buildAttempted :: BuildStatus -> BuildOutcome -> Bool+    -- And not if it didn't need rebuilding in the first place.+    buildAttempted buildStatus _buildOutcome+      | not (buildStatusRequiresBuild buildStatus)+      = False++    -- And not if it was skipped due to a dep failing first.+    buildAttempted _ (Left BuildFailure {buildFailureReason})+      | DependentFailed _ <- buildFailureReason+      = False++    -- Otherwise, succeeded or failed, yes the build was tried.+    buildAttempted _ (Left BuildFailure {}) = True+    buildAttempted _ (Right _)              = True++    lookupBuildStatusRequiresBuild def ipkgid =+      case Map.lookup ipkgid pkgBuildStatus of+        Nothing          -> def -- Not in the plan subset we did the dry-run on+        Just buildStatus -> buildStatusRequiresBuild buildStatus++    packagesBuildLocal =+      selectPlanPackageIdSet $ \pkg ->+        case pkg of+          InstallPlan.PreExisting _     -> False+          InstallPlan.Installed   _     -> False+          InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg++    packagesBuildInplace =+      selectPlanPackageIdSet $ \pkg ->+        case pkg of+          InstallPlan.PreExisting _     -> False+          InstallPlan.Installed   _     -> False+          InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg+                                        == BuildInplaceOnly++    packagesAlreadyInStore =+      selectPlanPackageIdSet $ \pkg ->+        case pkg of+          InstallPlan.PreExisting _ -> True+          InstallPlan.Installed   _ -> True+          InstallPlan.Configured  _ -> False++    selectPlanPackageIdSet p = Map.keysSet+                             . Map.filter p+                             $ InstallPlan.toMap plan++++updatePostBuildProjectStatus :: Verbosity+                             -> DistDirLayout+                             -> ElaboratedInstallPlan+                             -> BuildStatusMap+                             -> BuildOutcomes+                             -> IO PostBuildProjectStatus+updatePostBuildProjectStatus verbosity distDirLayout+                             elaboratedInstallPlan+                             pkgsBuildStatus buildOutcomes = do++    -- Read the previous up-to-date set, update it and write it back+    previousUpToDate   <- readPackagesUpToDateCacheFile distDirLayout+    let currentBuildStatus@PostBuildProjectStatus{..}+                        = postBuildProjectStatus+                            elaboratedInstallPlan+                            previousUpToDate+                            pkgsBuildStatus+                            buildOutcomes+    let currentUpToDate = packagesProbablyUpToDate+    writePackagesUpToDateCacheFile distDirLayout currentUpToDate++    -- Report various possibly interesting things+    -- We additionally intersect with the packagesBuildInplace so that+    -- we don't show huge numbers of boring packages from the store.+    debugNoWrap verbosity $+        "packages definitely up to date: "+     ++ displayPackageIdSet (packagesDefinitelyUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages previously probably up to date: "+     ++ displayPackageIdSet (previousUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages now probably up to date: "+     ++ displayPackageIdSet (packagesProbablyUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages newly up to date: "+     ++ displayPackageIdSet (packagesDefinitelyUpToDate+            `Set.difference` previousUpToDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages out to date: "+     ++ displayPackageIdSet (packagesOutOfDate+          `Set.intersection` packagesBuildInplace)++    debugNoWrap verbosity $+        "packages invalid due to dep change: "+     ++ displayPackageIdSet packagesInvalidByChangedLibDeps++    debugNoWrap verbosity $+        "packages invalid due to build failure: "+     ++ displayPackageIdSet packagesInvalidByFailedBuild++    return currentBuildStatus+  where+    displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList++-- | Helper for reading the cache file.+--+-- This determines the type and format of the binary cache file.+--+readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate+readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =+    handleDoesNotExist Set.empty $+    handleDecodeFailure $+      withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd ->+        Binary.decodeOrFailIO =<< BS.hGetContents hnd+  where+    handleDecodeFailure = fmap (either (const Set.empty) id)++-- | Helper for writing the package up-to-date cache file.+--+-- This determines the type and format of the binary cache file.+--+writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()+writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =+    writeFileAtomic (distProjectCacheFile "up-to-date") $+      Binary.encode upToDate++-- | Prepare a package environment that includes all the library dependencies+-- for a plan.+--+-- When running cabal new-exec, we want to set things up so that the compiler+-- can find all the right packages (and nothing else). This function is+-- intended to do that work. It takes a location where it can write files+-- temporarily, in case the compiler wants to learn this information via the+-- filesystem, and returns any environment variable overrides the compiler+-- needs.+createPackageEnvironment :: Verbosity+                         -> FilePath+                         -> ElaboratedInstallPlan+                         -> ElaboratedSharedConfig+                         -> PostBuildProjectStatus+                         -> IO [(String, Maybe String)]+createPackageEnvironment verbosity+                         path+                         elaboratedPlan+                         elaboratedShared+                         buildStatus+  | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC+  = do+    envFileM <- writePlanGhcEnvironment+      path+      elaboratedPlan+      elaboratedShared+      buildStatus+    case envFileM of+      Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)]+      Nothing -> do+        warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail"+        return []+  | otherwise+  = do+    warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"+    return []++-- Writing .ghc.environment files+--++writePlanGhcEnvironment :: FilePath+                        -> ElaboratedInstallPlan+                        -> ElaboratedSharedConfig+                        -> PostBuildProjectStatus+                        -> IO (Maybe FilePath)+writePlanGhcEnvironment path+                        elaboratedInstallPlan+                        ElaboratedSharedConfig {+                          pkgConfigCompiler = compiler,+                          pkgConfigPlatform = platform+                        }+                        postBuildStatus+  | compilerFlavor compiler == GHC+  , supportsPkgEnvFiles (getImplInfo compiler)+  --TODO: check ghcjs compat+  = fmap Just $ writeGhcEnvironmentFile+      path+      platform (compilerVersion compiler)+      (renderGhcEnvironmentFile path+                                elaboratedInstallPlan+                                postBuildStatus)+    --TODO: [required eventually] support for writing user-wide package+    -- environments, e.g. like a global project, but we would not put the+    -- env file in the home dir, rather it lives under ~/.ghc/++writePlanGhcEnvironment _ _ _ _ = return Nothing++renderGhcEnvironmentFile :: FilePath+                         -> ElaboratedInstallPlan+                         -> PostBuildProjectStatus+                         -> [GhcEnvironmentFileEntry]+renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan+                         postBuildStatus =+    headerComment+  : simpleGhcEnvironmentFile packageDBs unitIds+  where+    headerComment =+        GhcEnvFileComment+      $ "This is a GHC environment file written by cabal. This means you can\n"+     ++ "run ghc or ghci and get the environment of the project as a whole.\n"+     ++ "But you still need to use cabal repl $target to get the environment\n"+     ++ "of specific components (libs, exes, tests etc) because each one can\n"+     ++ "have its own source dirs, cpp flags etc.\n\n"+    unitIds    = selectGhcEnvironmentFileLibraries postBuildStatus+    packageDBs = relativePackageDBPaths projectRootDir $+                 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan+++argsEquivalentOfGhcEnvironmentFile+  :: Compiler+  -> DistDirLayout+  -> ElaboratedInstallPlan+  -> PostBuildProjectStatus+  -> [String]+argsEquivalentOfGhcEnvironmentFile compiler =+  case compilerId compiler+  of CompilerId GHC   _ -> argsEquivalentOfGhcEnvironmentFileGhc+     CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc+     CompilerId _     _ -> error "Only GHC and GHCJS are supported"++-- TODO remove this when we drop support for non-.ghc.env ghc+argsEquivalentOfGhcEnvironmentFileGhc+  :: DistDirLayout+  -> ElaboratedInstallPlan+  -> PostBuildProjectStatus+  -> [String]+argsEquivalentOfGhcEnvironmentFileGhc+  distDirLayout+  elaboratedInstallPlan+  postBuildStatus =+    clearPackageDbStackFlag+ ++ packageDbArgsDb packageDBs+ ++ foldMap packageIdFlag packageIds+  where+    projectRootDir = distProjectRootDirectory distDirLayout+    packageIds = selectGhcEnvironmentFileLibraries postBuildStatus+    packageDBs = relativePackageDBPaths projectRootDir $+                 selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan+    -- TODO use proper flags? but packageDbArgsDb is private+    clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]+    packageIdFlag uid = ["-package-id", prettyShow uid]+++-- We're producing an environment for users to use in ghci, so of course+-- that means libraries only (can't put exes into the ghc package env!).+-- The library environment should be /consistent/ with the environment+-- that each of the packages in the project use (ie same lib versions).+-- So that means all the normal library dependencies of all the things+-- in the project (including deps of exes that are local to the project).+-- We do not however want to include the dependencies of Setup.hs scripts,+-- since these are generally uninteresting but also they need not in+-- general be consistent with the library versions that packages local to+-- the project use (recall that Setup.hs script's deps can be picked+-- independently of other packages in the project).+--+-- So, our strategy is as follows:+--+-- produce a dependency graph of all the packages in the install plan,+-- but only consider normal library deps as edges in the graph. Thus we+-- exclude the dependencies on Setup.hs scripts (in the case of+-- per-component granularity) or of Setup.hs scripts (in the case of+-- per-package granularity). Then take a dependency closure, using as+-- roots all the packages/components local to the project. This will+-- exclude Setup scripts and their dependencies.+--+-- Note: this algorithm will have to be adapted if/when the install plan+-- is extended to cover multiple compilers at once, and may also have to+-- change if we start to treat unshared deps of test suites in a similar+-- way to how we treat Setup.hs script deps (ie being able to pick them+-- independently).+--+-- Since we had to use all the local packages, including exes, (as roots+-- to find the libs) then those exes still end up in our list so we have+-- to filter them out at the end.+--+selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]+selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =+    case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of+      Nothing    -> error "renderGhcEnvironmentFile: broken dep closure"+      Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes+                            , hasUpToDateLib pkg ]+  where+    hasUpToDateLib planpkg = case planpkg of+      -- A pre-existing global lib+      InstallPlan.PreExisting  _ -> True++      -- A package in the store. Check it's a lib.+      InstallPlan.Installed  pkg -> elabRequiresRegistration pkg++      -- A package we were installing this time, either destined for the store+      -- or just locally. Check it's a lib and that it is probably up to date.+      InstallPlan.Configured pkg ->+          elabRequiresRegistration pkg+       && installedUnitId pkg `Set.member` packagesProbablyUpToDate+++selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack+selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =+    -- If we have any inplace packages then their package db stack is the+    -- one we should use since it'll include the store + the local db but+    -- it's certainly possible to have no local inplace packages+    -- e.g. just "extra" packages coming from the store.+    case (inplacePackages, sourcePackages) of+      ([], pkgs) -> checkSamePackageDBs pkgs+      (pkgs, _)  -> checkSamePackageDBs pkgs+  where+    checkSamePackageDBs pkgs =+      case ordNub (map elabBuildPackageDBStack pkgs) of+        [packageDbs] -> packageDbs+        []           -> []+        _            -> error $ "renderGhcEnvironmentFile: packages with "+                             ++ "different package db stacks"+        -- This should not happen at the moment but will happen as soon+        -- as we support projects where we build packages with different+        -- compilers, at which point we have to consider how to adapt+        -- this feature, e.g. write out multiple env files, one for each+        -- compiler / project profile.++    inplacePackages =+      [ srcpkg+      | srcpkg <- sourcePackages+      , elabBuildStyle srcpkg == BuildInplaceOnly ]+    sourcePackages =+      [ srcpkg+      | pkg <- InstallPlan.toList elaboratedInstallPlan+      , srcpkg <- maybeToList $ case pkg of+                    InstallPlan.Configured srcpkg -> Just srcpkg+                    InstallPlan.Installed  srcpkg -> Just srcpkg+                    InstallPlan.PreExisting _     -> Nothing+      ]++relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack+relativePackageDBPaths relroot = map (relativePackageDBPath relroot)++relativePackageDBPath :: FilePath -> PackageDB -> PackageDB+relativePackageDBPath relroot pkgdb =+    case pkgdb of+      GlobalPackageDB        -> GlobalPackageDB+      UserPackageDB          -> UserPackageDB+      SpecificPackageDB path -> SpecificPackageDB relpath+        where relpath = makeRelative relroot path
+ src/Distribution/Client/ProjectPlanning.hs view
@@ -0,0 +1,3881 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}++-- | Planning how to build everything in a project.+--+module Distribution.Client.ProjectPlanning (+    -- * elaborated install plan types+    ElaboratedInstallPlan,+    ElaboratedConfiguredPackage(..),+    ElaboratedPlanPackage,+    ElaboratedSharedConfig(..),+    ElaboratedReadyPackage,+    BuildStyle(..),+    CabalFileText,++    -- * Producing the elaborated install plan+    rebuildProjectConfig,+    rebuildInstallPlan,++    -- * Build targets+    availableTargets,+    AvailableTarget(..),+    AvailableTargetStatus(..),+    TargetRequested(..),+    ComponentTarget(..),+    SubComponentTarget(..),+    showComponentTarget,+    nubComponentTargets,++    -- * Selecting a plan subset+    pruneInstallPlanToTargets,+    TargetAction(..),+    pruneInstallPlanToDependencies,+    CannotPruneDependencies(..),++    -- * Utils required for building+    pkgHasEphemeralBuildTargets,+    elabBuildTargetWholeComponents,++    -- * Setup.hs CLI flags for building+    setupHsScriptOptions,+    setupHsConfigureFlags,+    setupHsConfigureArgs,+    setupHsBuildFlags,+    setupHsBuildArgs,+    setupHsReplFlags,+    setupHsReplArgs,+    setupHsTestFlags,+    setupHsTestArgs,+    setupHsBenchFlags,+    setupHsBenchArgs,+    setupHsCopyFlags,+    setupHsRegisterFlags,+    setupHsHaddockFlags,+    setupHsHaddockArgs,++    packageHashInputs,++    -- * Path construction+    binDirectoryFor,+    binDirectories,+    storePackageInstallDirs,+    storePackageInstallDirs'+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import           Distribution.Client.HashValue+import           Distribution.Client.ProjectPlanning.Types as Ty+import           Distribution.Client.PackageHash+import           Distribution.Client.RebuildMonad+import           Distribution.Client.Store+import           Distribution.Client.ProjectConfig+import           Distribution.Client.ProjectPlanOutput++import           Distribution.Client.Types+import qualified Distribution.Client.InstallPlan as InstallPlan+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan+import           Distribution.Client.Dependency+import           Distribution.Client.Dependency.Types+import qualified Distribution.Client.IndexUtils as IndexUtils+import           Distribution.Client.Init (incVersion)+import           Distribution.Client.Targets (userToPackageConstraint)+import           Distribution.Client.DistDirLayout+import           Distribution.Client.SetupWrapper+import           Distribution.Client.JobControl+import           Distribution.Client.FetchUtils+import           Distribution.Client.Config+import qualified Hackage.Security.Client as Sec+import           Distribution.Client.Setup hiding (packageName, cabalVersion)+import           Distribution.Utils.NubList+import           Distribution.Utils.LogProgress+import           Distribution.Utils.MapAccum++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import           Distribution.Solver.Types.ConstraintSource+import           Distribution.Solver.Types.LabeledPackageConstraint+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PkgConfigDb+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage+import           Distribution.Solver.Types.InstSolverPackage+import           Distribution.Solver.Types.SourcePackage+import           Distribution.Solver.Types.Settings++import           Distribution.CabalSpecVersion+import           Distribution.ModuleName+import           Distribution.Package+import           Distribution.Types.AnnotatedId+import           Distribution.Types.ComponentName+import           Distribution.Types.LibraryName+import           Distribution.Types.GivenComponent+  (GivenComponent(..))+import           Distribution.Types.PackageVersionConstraint+import           Distribution.Types.PkgconfigDependency+import           Distribution.Types.UnqualComponentName+import           Distribution.System+import qualified Distribution.PackageDescription as Cabal+import qualified Distribution.PackageDescription as PD+import qualified Distribution.PackageDescription.Configuration as PD+import           Distribution.Simple.PackageIndex (InstalledPackageIndex)+import           Distribution.Simple.Compiler+import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate+import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate+import           Distribution.Simple.Program+import           Distribution.Simple.Program.Db+import           Distribution.Simple.Program.Find+import qualified Distribution.Simple.Setup as Cabal+import           Distribution.Simple.Setup+  (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault)+import qualified Distribution.Simple.Configure as Cabal+import qualified Distribution.Simple.LocalBuildInfo as Cabal+import           Distribution.Simple.LocalBuildInfo+                   ( Component(..), pkgComponents, componentBuildInfo+                   , componentName )+import qualified Distribution.Simple.InstallDirs as InstallDirs+import qualified Distribution.InstalledPackageInfo as IPI++import           Distribution.Backpack.ConfiguredComponent+import           Distribution.Backpack.LinkedComponent+import           Distribution.Backpack.ComponentsGraph+import           Distribution.Backpack.ModuleShape+import           Distribution.Backpack.FullUnitId+import           Distribution.Backpack+import           Distribution.Types.ComponentInclude++import           Distribution.Simple.Utils+import           Distribution.Version++import qualified Distribution.Compat.Graph as Graph+import           Distribution.Compat.Graph(IsNode(..))++import           Data.Foldable (fold)+import           Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma)+import qualified Text.PrettyPrint as Disp+import qualified Data.Map as Map+import qualified Data.Set as Set+import           Control.Monad.State as State+import           Control.Exception (assert)+import           Data.List (groupBy)+import qualified Data.List.NonEmpty as NE+import           System.FilePath++------------------------------------------------------------------------------+-- * Elaborated install plan+------------------------------------------------------------------------------++-- "Elaborated" -- worked out with great care and nicety of detail;+--                 executed with great minuteness: elaborate preparations;+--                 elaborate care.+--+-- So here's the idea:+--+-- Rather than a miscellaneous collection of 'ConfigFlags', 'InstallFlags' etc+-- all passed in as separate args and which are then further selected,+-- transformed etc during the execution of the build. Instead we construct+-- an elaborated install plan that includes everything we will need, and then+-- during the execution of the plan we do as little transformation of this+-- info as possible.+--+-- So we're trying to split the work into two phases: construction of the+-- elaborated install plan (which as far as possible should be pure) and+-- then simple execution of that plan without any smarts, just doing what the+-- plan says to do.+--+-- So that means we need a representation of this fully elaborated install+-- plan. The representation consists of two parts:+--+-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a+--   representation of source packages that includes a lot more detail about+--   that package's individual configuration+--+-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for+--   every package in a plan. Rather than duplicate that info every entry in+--   the 'GenericInstallPlan' we keep that separately.+--+-- The division between the shared and per-package config is /not set in stone+-- for all time/. For example if we wanted to generalise the install plan to+-- describe a situation where we want to build some packages with GHC and some+-- with GHCJS then the platform and compiler would no longer be shared between+-- all packages but would have to be per-package (probably with some sanity+-- condition on the graph structure).+--++-- Refer to ProjectPlanning.Types for details of these important types:++-- type ElaboratedInstallPlan = ...+-- type ElaboratedPlanPackage = ...+-- data ElaboratedSharedConfig = ...+-- data ElaboratedConfiguredPackage = ...+-- data BuildStyle =+++-- | Check that an 'ElaboratedConfiguredPackage' actually makes+-- sense under some 'ElaboratedSharedConfig'.+sanityCheckElaboratedConfiguredPackage+    :: ElaboratedSharedConfig+    -> ElaboratedConfiguredPackage+    -> a+    -> a+sanityCheckElaboratedConfiguredPackage sharedConfig+                             elab@ElaboratedConfiguredPackage{..} =+    (case elabPkgOrComp of+        ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg+        ElabComponent comp -> sanityCheckElaboratedComponent elab comp)++    -- either a package is being built inplace, or the+    -- 'installedPackageId' we assigned is consistent with+    -- the 'hashedInstalledPackageId' we would compute from+    -- the elaborated configured package+  . assert (elabBuildStyle == BuildInplaceOnly ||+     elabComponentId == hashedInstalledPackageId+                            (packageHashInputs sharedConfig elab))++    -- the stanzas explicitly disabled should not be available+  . assert (optStanzaSetNull $+        optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable)++    -- either a package is built inplace, or we are not attempting to+    -- build any test suites or benchmarks (we never build these+    -- for remote packages!)+  . assert (elabBuildStyle == BuildInplaceOnly ||+     optStanzaSetNull elabStanzasAvailable)++sanityCheckElaboratedComponent+    :: ElaboratedConfiguredPackage+    -> ElaboratedComponent+    -> a+    -> a+sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..}+                               ElaboratedComponent{..} =++    -- Should not be building bench or test if not inplace.+    assert (elabBuildStyle == BuildInplaceOnly ||+     case compComponentName of+        Nothing              -> True+        Just (CLibName _)    -> True+        Just (CExeName _)    -> True+        -- This is interesting: there's no way to declare a dependency+        -- on a foreign library at the moment, but you may still want+        -- to install these to the store+        Just (CFLibName _)   -> True+        Just (CBenchName _)  -> False+        Just (CTestName _)   -> False)+++sanityCheckElaboratedPackage+    :: ElaboratedConfiguredPackage+    -> ElaboratedPackage+    -> a+    -> a+sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..}+                             ElaboratedPackage{..} =+    -- we should only have enabled stanzas that actually can be built+    -- (according to the solver)+    assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable)++    -- the stanzas that the user explicitly requested should be+    -- enabled (by the previous test, they are also available)+  . assert (optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested+                `optStanzaSetIsSubset` pkgStanzasEnabled)++------------------------------------------------------------------------------+-- * Deciding what to do: making an 'ElaboratedInstallPlan'+------------------------------------------------------------------------------++-- | Return the up-to-date project config and information about the local+-- packages within the project.+--+rebuildProjectConfig :: Verbosity+                     -> DistDirLayout+                     -> ProjectConfig+                     -> IO ( ProjectConfig+                           , [PackageSpecifier UnresolvedSourcePackage] )+rebuildProjectConfig verbosity+                     distDirLayout@DistDirLayout {+                       distProjectRootDirectory,+                       distDirectory,+                       distProjectCacheFile,+                       distProjectCacheDirectory,+                       distProjectFile+                     }+                     cliConfig = do++    fileMonitorProjectConfigKey <- do+      configPath <- getConfigFilePath projectConfigConfigFile+      return (configPath, distProjectFile "")++    (projectConfig, localPackages) <-+      runRebuild distProjectRootDirectory+      $ rerunIfChanged verbosity+                       fileMonitorProjectConfig+                       fileMonitorProjectConfigKey+      $ do+          liftIO $ info verbosity "Project settings changed, reconfiguring..."+          projectConfig <- phaseReadProjectConfig+          localPackages <- phaseReadLocalPackages projectConfig+          return (projectConfig, localPackages)++    info verbosity+      $ unlines+      $ ("this build was affected by the following (project) config files:" :)+      $ [ "- " ++ path+        | Explicit path <- Set.toList $ projectConfigProvenance projectConfig+        ]++    return (projectConfig <> cliConfig, localPackages)++  where++    ProjectConfigShared { projectConfigConfigFile } =+      projectConfigShared cliConfig++    fileMonitorProjectConfig =+      newFileMonitor (distProjectCacheFile "config") :: FileMonitor+          (FilePath, FilePath)+          (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])++    -- Read the cabal.project (or implicit config) and combine it with+    -- arguments from the command line+    --+    phaseReadProjectConfig :: Rebuild ProjectConfig+    phaseReadProjectConfig = do+      readProjectConfig verbosity projectConfigConfigFile distDirLayout++    -- Look for all the cabal packages in the project+    -- some of which may be local src dirs, tarballs etc+    --+    phaseReadLocalPackages :: ProjectConfig+                           -> Rebuild [PackageSpecifier UnresolvedSourcePackage]+    phaseReadLocalPackages projectConfig@ProjectConfig {+                               projectConfigShared,+                               projectConfigBuildOnly+                             } = do+      pkgLocations <- findProjectPackages distDirLayout projectConfig++      -- Create folder only if findProjectPackages did not throw a+      -- BadPackageLocations exception.+      liftIO $ do+        createDirectoryIfMissingVerbose verbosity True distDirectory+        createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory++      fetchAndReadSourcePackages verbosity distDirLayout+                                 projectConfigShared+                                 projectConfigBuildOnly+                                 pkgLocations+++-- | Return an up-to-date elaborated install plan.+--+-- Two variants of the install plan are returned: with and without packages+-- from the store. That is, the \"improved\" plan where source packages are+-- replaced by pre-existing installed packages from the store (when their ids+-- match), and also the original elaborated plan which uses primarily source+-- packages.++-- The improved plan is what we use for building, but the original elaborated+-- plan is useful for reporting and configuration. For example the @freeze@+-- command needs the source package info to know about flag choices and+-- dependencies of executables and setup scripts.+--+rebuildInstallPlan :: Verbosity+                   -> DistDirLayout -> CabalDirLayout+                   -> ProjectConfig+                   -> [PackageSpecifier UnresolvedSourcePackage]+                   -> IO ( ElaboratedInstallPlan  -- with store packages+                         , ElaboratedInstallPlan  -- with source packages+                         , ElaboratedSharedConfig+                         , IndexUtils.TotalIndexState+                         , IndexUtils.ActiveRepos+                         )+                      -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@+rebuildInstallPlan verbosity+                   distDirLayout@DistDirLayout {+                     distProjectRootDirectory,+                     distProjectCacheFile+                   }+                   CabalDirLayout {+                     cabalStoreDirLayout+                   } = \projectConfig localPackages ->+    runRebuild distProjectRootDirectory $ do+    progsearchpath <- liftIO $ getSystemSearchPath+    let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty }++    -- The overall improved plan is cached+    rerunIfChanged verbosity fileMonitorImprovedPlan+                   -- react to changes in the project config,+                   -- the package .cabal files and the path+                   (projectConfigMonitored, localPackages, progsearchpath) $ do++      -- And so is the elaborated plan that the improved plan based on+      (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-+        rerunIfChanged verbosity fileMonitorElaboratedPlan+                       (projectConfigMonitored, localPackages,+                        progsearchpath) $ do++          compilerEtc   <- phaseConfigureCompiler projectConfig+          _             <- phaseConfigurePrograms projectConfig compilerEtc+          (solverPlan, pkgConfigDB, totalIndexState, activeRepos)+                        <- phaseRunSolver         projectConfig+                                                  compilerEtc+                                                  localPackages+          (elaboratedPlan,+           elaboratedShared) <- phaseElaboratePlan projectConfig+                                                   compilerEtc pkgConfigDB+                                                   solverPlan+                                                   localPackages++          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared+          return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)++      -- The improved plan changes each time we install something, whereas+      -- the underlying elaborated plan only changes when input config+      -- changes, so it's worth caching them separately.+      improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared++      return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)++  where+    fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"+    fileMonitorSolverPlan     = newFileMonitorInCacheDir "solver-plan"+    fileMonitorSourceHashes   = newFileMonitorInCacheDir "source-hashes"+    fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"+    fileMonitorImprovedPlan   = newFileMonitorInCacheDir "improved-plan"++    newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b+    newFileMonitorInCacheDir  = newFileMonitor . distProjectCacheFile+++    -- Configure the compiler we're using.+    --+    -- This is moderately expensive and doesn't change that often so we cache+    -- it independently.+    --+    phaseConfigureCompiler :: ProjectConfig+                           -> Rebuild (Compiler, Platform, ProgramDb)+    phaseConfigureCompiler ProjectConfig {+                             projectConfigShared = ProjectConfigShared {+                               projectConfigHcFlavor,+                               projectConfigHcPath,+                               projectConfigHcPkg+                             },+                             projectConfigLocalPackages = PackageConfig {+                               packageConfigProgramPaths,+                               packageConfigProgramArgs,+                               packageConfigProgramPathExtra+                             }+                           } = do+        progsearchpath <- liftIO $ getSystemSearchPath+        rerunIfChanged verbosity fileMonitorCompiler+                       (hcFlavor, hcPath, hcPkg, progsearchpath,+                        packageConfigProgramPaths,+                        packageConfigProgramArgs,+                        packageConfigProgramPathExtra) $ do++          liftIO $ info verbosity "Compiler settings changed, reconfiguring..."+          result@(_, _, progdb') <- liftIO $+            Cabal.configCompilerEx+              hcFlavor hcPath hcPkg+              progdb verbosity++        -- Note that we added the user-supplied program locations and args+        -- for /all/ programs, not just those for the compiler prog and+        -- compiler-related utils. In principle we don't know which programs+        -- the compiler will configure (and it does vary between compilers).+        -- We do know however that the compiler will only configure the+        -- programs it cares about, and those are the ones we monitor here.+          monitorFiles (programsMonitorFiles progdb')++          return result+      where+        hcFlavor = flagToMaybe projectConfigHcFlavor+        hcPath   = flagToMaybe projectConfigHcPath+        hcPkg    = flagToMaybe projectConfigHcPkg+        progdb   =+            userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))+          . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))+          . modifyProgramSearchPath+              (++ [ ProgramSearchPathDir dir+                  | dir <- fromNubList packageConfigProgramPathExtra ])+          $ defaultProgramDb+++    -- Configuring other programs.+    --+    -- Having configred the compiler, now we configure all the remaining+    -- programs. This is to check we can find them, and to monitor them for+    -- changes.+    --+    -- TODO: [required eventually] we don't actually do this yet.+    --+    -- We rely on the fact that the previous phase added the program config for+    -- all local packages, but that all the programs configured so far are the+    -- compiler program or related util programs.+    --+    phaseConfigurePrograms :: ProjectConfig+                           -> (Compiler, Platform, ProgramDb)+                           -> Rebuild ()+    phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do+        -- Users are allowed to specify program locations independently for+        -- each package (e.g. to use a particular version of a pre-processor+        -- for some packages). However they cannot do this for the compiler+        -- itself as that's just not going to work. So we check for this.+        liftIO $ checkBadPerPackageCompilerPaths+          (configuredPrograms compilerprogdb)+          (getMapMappend (projectConfigSpecificPackage projectConfig))++        --TODO: [required eventually] find/configure other programs that the+        -- user specifies.++        --TODO: [required eventually] find/configure all build-tools+        -- but note that some of them may be built as part of the plan.+++    -- Run the solver to get the initial install plan.+    -- This is expensive so we cache it independently.+    --+    phaseRunSolver+        :: ProjectConfig+        -> (Compiler, Platform, ProgramDb)+        -> [PackageSpecifier UnresolvedSourcePackage]+        -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)+    phaseRunSolver projectConfig@ProjectConfig {+                     projectConfigShared,+                     projectConfigBuildOnly+                   }+                   (compiler, platform, progdb)+                   localPackages =+        rerunIfChanged verbosity fileMonitorSolverPlan+                       (solverSettings,+                        localPackages, localPackagesEnabledStanzas,+                        compiler, platform, programDbSignature progdb) $ do++          installedPkgIndex <- getInstalledPackages verbosity+                                                    compiler progdb platform+                                                    corePackageDbs+          (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx+              (solverSettingIndexState solverSettings)+              (solverSettingActiveRepos solverSettings)+          pkgConfigDB       <- getPkgConfigDb verbosity progdb++          --TODO: [code cleanup] it'd be better if the Compiler contained the+          -- ConfiguredPrograms that it needs, rather than relying on the progdb+          -- since we don't need to depend on all the programs here, just the+          -- ones relevant for the compiler.++          liftIO $ do+            solver <- chooseSolver verbosity+                                   (solverSettingSolver solverSettings)+                                   (compilerInfo compiler)++            notice verbosity "Resolving dependencies..."+            plan <- foldProgress logMsg (die' verbosity) return $+              planPackages verbosity compiler platform solver solverSettings+                           installedPkgIndex sourcePkgDb pkgConfigDB+                           localPackages localPackagesEnabledStanzas+            return (plan, pkgConfigDB, tis, ar)+      where+        corePackageDbs = [GlobalPackageDB]+        withRepoCtx    = projectConfigWithSolverRepoContext verbosity+                           projectConfigShared+                           projectConfigBuildOnly+        solverSettings = resolveSolverSettings projectConfig+        logMsg message rest = debugNoWrap verbosity message >> rest++        localPackagesEnabledStanzas =+          Map.fromList+            [ (pkgname, stanzas)+            | pkg <- localPackages+              -- TODO: misnormer: we should separate+              -- builtin/global/inplace/local packages+              -- and packages explicitly mentioned in the project+              --+            , let pkgname            = pkgSpecifierTarget pkg+                  testsEnabled       = lookupLocalPackageConfig+                                         packageConfigTests+                                         projectConfig pkgname+                  benchmarksEnabled  = lookupLocalPackageConfig+                                         packageConfigBenchmarks+                                         projectConfig pkgname+                  isLocal = isJust (shouldBeLocal pkg)+                  stanzas+                    | isLocal = Map.fromList $+                      [ (TestStanzas, enabled)+                      | enabled <- flagToList testsEnabled ] +++                      [ (BenchStanzas , enabled)+                      | enabled <- flagToList benchmarksEnabled ]+                    | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ]+            ]++    -- Elaborate the solver's install plan to get a fully detailed plan. This+    -- version of the plan has the final nix-style hashed ids.+    --+    phaseElaboratePlan :: ProjectConfig+                       -> (Compiler, Platform, ProgramDb)+                       -> PkgConfigDb+                       -> SolverInstallPlan+                       -> [PackageSpecifier (SourcePackage (PackageLocation loc))]+                       -> Rebuild ( ElaboratedInstallPlan+                                  , ElaboratedSharedConfig )+    phaseElaboratePlan ProjectConfig {+                         projectConfigShared,+                         projectConfigAllPackages,+                         projectConfigLocalPackages,+                         projectConfigSpecificPackage,+                         projectConfigBuildOnly+                       }+                       (compiler, platform, progdb) pkgConfigDB+                       solverPlan localPackages = do++        liftIO $ debug verbosity "Elaborating the install plan..."++        sourcePackageHashes <-+          rerunIfChanged verbosity fileMonitorSourceHashes+                         (packageLocationsSignature solverPlan) $+            getPackageSourceHashes verbosity withRepoCtx solverPlan++        defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler+        (elaboratedPlan, elaboratedShared)+          <- liftIO . runLogProgress verbosity $+              elaborateInstallPlan+                verbosity+                platform compiler progdb pkgConfigDB+                distDirLayout+                cabalStoreDirLayout+                solverPlan+                localPackages+                sourcePackageHashes+                defaultInstallDirs+                projectConfigShared+                projectConfigAllPackages+                projectConfigLocalPackages+                (getMapMappend projectConfigSpecificPackage)+        let instantiatedPlan+              = instantiateInstallPlan+                  cabalStoreDirLayout+                  defaultInstallDirs+                  elaboratedShared+                  elaboratedPlan+        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)+        return (instantiatedPlan, elaboratedShared)+      where+        withRepoCtx = projectConfigWithSolverRepoContext verbosity+                        projectConfigShared+                        projectConfigBuildOnly++    -- Update the files we maintain that reflect our current build environment.+    -- In particular we maintain a JSON representation of the elaborated+    -- install plan (but not the improved plan since that reflects the state+    -- of the build rather than just the input environment).+    --+    phaseMaintainPlanOutputs :: ElaboratedInstallPlan+                             -> ElaboratedSharedConfig+                             -> Rebuild ()+    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do+        debug verbosity "Updating plan.json"+        writePlanExternalRepresentation+          distDirLayout+          elaboratedPlan+          elaboratedShared+++    -- Improve the elaborated install plan. The elaborated plan consists+    -- mostly of source packages (with full nix-style hashed ids). Where+    -- corresponding installed packages already exist in the store, replace+    -- them in the plan.+    --+    -- Note that we do monitor the store's package db here, so we will redo+    -- this improvement phase when the db changes -- including as a result of+    -- executing a plan and installing things.+    --+    phaseImprovePlan :: ElaboratedInstallPlan+                     -> ElaboratedSharedConfig+                     -> Rebuild ElaboratedInstallPlan+    phaseImprovePlan elaboratedPlan elaboratedShared = do++        liftIO $ debug verbosity "Improving the install plan..."+        storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid+        let improvedPlan = improveInstallPlanWithInstalledPackages+                             storePkgIdSet+                             elaboratedPlan+        liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)+        -- TODO: [nice to have] having checked which packages from the store+        -- we're using, it may be sensible to sanity check those packages+        -- by loading up the compiler package db and checking everything+        -- matches up as expected, e.g. no dangling deps, files deleted.+        return improvedPlan+      where+        compid = compilerId (pkgConfigCompiler elaboratedShared)+++programsMonitorFiles :: ProgramDb -> [MonitorFilePath]+programsMonitorFiles progdb =+    [ monitor+    | prog    <- configuredPrograms progdb+    , monitor <- monitorFileSearchPath (programMonitorFiles prog)+                                       (programPath prog)+    ]++-- | Select the bits of a 'ProgramDb' to monitor for value changes.+-- Use 'programsMonitorFiles' for the files to monitor.+--+programDbSignature :: ProgramDb -> [ConfiguredProgram]+programDbSignature progdb =+    [ prog { programMonitorFiles = []+           , programOverrideEnv  = filter ((/="PATH") . fst)+                                          (programOverrideEnv prog) }+    | prog <- configuredPrograms progdb ]++getInstalledPackages :: Verbosity+                     -> Compiler -> ProgramDb -> Platform+                     -> PackageDBStack+                     -> Rebuild InstalledPackageIndex+getInstalledPackages verbosity compiler progdb platform packagedbs = do+    monitorFiles . map monitorFileOrDirectory+      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles+                    verbosity compiler+                    packagedbs progdb platform)+    liftIO $ IndexUtils.getInstalledPackages+               verbosity compiler+               packagedbs progdb++{-+--TODO: [nice to have] use this but for sanity / consistency checking+getPackageDBContents :: Verbosity+                     -> Compiler -> ProgramDb -> Platform+                     -> PackageDB+                     -> Rebuild InstalledPackageIndex+getPackageDBContents verbosity compiler progdb platform packagedb = do+    monitorFiles . map monitorFileOrDirectory+      =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles+                    verbosity compiler+                    [packagedb] progdb platform)+    liftIO $ do+      createPackageDBIfMissing verbosity compiler progdb packagedb+      Cabal.getPackageDBContents verbosity compiler+                                 packagedb progdb+-}++getSourcePackages+    :: Verbosity+    -> (forall a. (RepoContext -> IO a) -> IO a)+    -> Maybe IndexUtils.TotalIndexState+    -> Maybe IndexUtils.ActiveRepos+    -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)+getSourcePackages verbosity withRepoCtx idxState activeRepos = do+    (sourcePkgDbWithTIS, repos) <-+      liftIO $+        withRepoCtx $ \repoctx -> do+          sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos+          return (sourcePkgDbWithTIS, repoContextRepos repoctx)++    traverse_ needIfExists+        . IndexUtils.getSourcePackagesMonitorFiles+        $ repos+    return sourcePkgDbWithTIS+++getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb+getPkgConfigDb verbosity progdb = do+    dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb+    -- Just monitor the dirs so we'll notice new .pc files.+    -- Alternatively we could monitor all the .pc files too.+    traverse_ monitorDirectoryStatus dirs+    liftIO $ readPkgConfigDb verbosity progdb+++-- | Select the config values to monitor for changes package source hashes.+packageLocationsSignature :: SolverInstallPlan+                          -> [(PackageId, PackageLocation (Maybe FilePath))]+packageLocationsSignature solverPlan =+    [ (packageId pkg, srcpkgSource pkg)+    | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})+        <- SolverInstallPlan.toList solverPlan+    ]+++-- | Get the 'HashValue' for all the source packages where we use hashes,+-- and download any packages required to do so.+--+-- Note that we don't get hashes for local unpacked packages.+--+getPackageSourceHashes :: Verbosity+                       -> (forall a. (RepoContext -> IO a) -> IO a)+                       -> SolverInstallPlan+                       -> Rebuild (Map PackageId PackageSourceHash)+getPackageSourceHashes verbosity withRepoCtx solverPlan = do++    -- Determine if and where to get the package's source hash from.+    --+    let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]+        allPkgLocations =+          [ (packageId pkg, srcpkgSource pkg)+          | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})+              <- SolverInstallPlan.toList solverPlan ]++        -- Tarballs that were local in the first place.+        -- We'll hash these tarball files directly.+        localTarballPkgs :: [(PackageId, FilePath)]+        localTarballPkgs =+          [ (pkgid, tarball)+          | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ]++        -- Tarballs from remote URLs. We must have downloaded these already+        -- (since we extracted the .cabal file earlier)+        remoteTarballPkgs =+          [ (pkgid, tarball)+          | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ]++        -- tarballs from source-repository-package stanzas+        sourceRepoTarballPkgs =+          [ (pkgid, tarball)+          | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ]++        -- Tarballs from repositories, either where the repository provides+        -- hashes as part of the repo metadata, or where we will have to+        -- download and hash the tarball.+        repoTarballPkgsWithMetadata    :: [(PackageId, Repo)]+        repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]+        (repoTarballPkgsWithMetadata,+         repoTarballPkgsWithoutMetadata) =+          partitionEithers+          [ case repo of+              RepoSecure{} -> Left  (pkgid, repo)+              _            -> Right (pkgid, repo)+          | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]++    -- For tarballs from repos that do not have hashes available we now have+    -- to check if the packages were downloaded already.+    --+    (repoTarballPkgsToDownload,+     repoTarballPkgsDownloaded)+      <- fmap partitionEithers $+         liftIO $ sequence+           [ do mtarball <- checkRepoTarballFetched repo pkgid+                case mtarball of+                  Nothing      -> return (Left  (pkgid, repo))+                  Just tarball -> return (Right (pkgid, tarball))+           | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]++    (hashesFromRepoMetadata,+     repoTarballPkgsNewlyDownloaded) <-+      -- Avoid having to initialise the repository (ie 'withRepoCtx') if we+      -- don't have to. (The main cost is configuring the http client.)+      if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata+      then return (Map.empty, [])+      else liftIO $ withRepoCtx $ \repoctx -> do++      -- For tarballs from repos that do have hashes available as part of the+      -- repo metadata we now load up the index for each repo and retrieve+      -- the hashes for the packages+      --+      hashesFromRepoMetadata <-+        Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions+        fmap (Map.fromList . concat) $+        sequence+          -- Reading the repo index is expensive so we group the packages by repo+          [ repoContextWithSecureRepo repoctx repo $ \secureRepo ->+              Sec.withIndex secureRepo $ \repoIndex ->+                sequence+                  [ do hash <- Sec.trusted <$> -- strip off Trusted tag+                               Sec.indexLookupHash repoIndex pkgid+                       -- Note that hackage-security currently uses SHA256+                       -- but this API could in principle give us some other+                       -- choice in future.+                       return (pkgid, hashFromTUF hash)+                  | pkgid <- pkgids ]+          | (repo, pkgids) <-+                map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp)))+              . NE.groupBy ((==)    `on` (remoteRepoName . repoRemote . snd))+              . sortBy  (compare `on` (remoteRepoName . repoRemote . snd))+              $ repoTarballPkgsWithMetadata+          ]++      -- For tarballs from repos that do not have hashes available, download+      -- the ones we previously determined we need.+      --+      repoTarballPkgsNewlyDownloaded <-+        sequence+          [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid+               return (pkgid, tarball)+          | (pkgid, repo) <- repoTarballPkgsToDownload ]++      return (hashesFromRepoMetadata,+              repoTarballPkgsNewlyDownloaded)++    -- Hash tarball files for packages where we have to do that. This includes+    -- tarballs that were local in the first place, plus tarballs from repos,+    -- either previously cached or freshly downloaded.+    --+    let allTarballFilePkgs :: [(PackageId, FilePath)]+        allTarballFilePkgs = localTarballPkgs+                          ++ remoteTarballPkgs+                          ++ sourceRepoTarballPkgs+                          ++ repoTarballPkgsDownloaded+                          ++ repoTarballPkgsNewlyDownloaded+    hashesFromTarballFiles <- liftIO $+      fmap Map.fromList $+      sequence+        [ do srchash <- readFileHashValue tarball+             return (pkgid, srchash)+        | (pkgid, tarball) <- allTarballFilePkgs+        ]+    monitorFiles [ monitorFile tarball+                 | (_pkgid, tarball) <- allTarballFilePkgs ]++    -- Return the combination+    return $! hashesFromRepoMetadata+           <> hashesFromTarballFiles+++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Verbosity+             -> Compiler+             -> Platform+             -> Solver -> SolverSettings+             -> InstalledPackageIndex+             -> SourcePackageDb+             -> PkgConfigDb+             -> [PackageSpecifier UnresolvedSourcePackage]+             -> Map PackageName (Map OptionalStanza Bool)+             -> Progress String String SolverInstallPlan+planPackages verbosity comp platform solver SolverSettings{..}+             installedPkgIndex sourcePkgDb pkgConfigDB+             localPackages pkgStanzasEnable =++    resolveDependencies+      platform (compilerInfo comp)+      pkgConfigDB solver+      resolverParams++  where++    --TODO: [nice to have] disable multiple instances restriction in+    -- the solver, but then make sure we can cope with that in the+    -- output.+    resolverParams =++        setMaxBackjumps solverSettingMaxBackjumps++      . setIndependentGoals solverSettingIndependentGoals++      . setReorderGoals solverSettingReorderGoals++      . setCountConflicts solverSettingCountConflicts++      . setFineGrainedConflicts solverSettingFineGrainedConflicts++      . setMinimizeConflictSet solverSettingMinimizeConflictSet++        --TODO: [required eventually] should only be configurable for+        --custom installs+   -- . setAvoidReinstalls solverSettingAvoidReinstalls++        --TODO: [required eventually] should only be configurable for+        --custom installs+   -- . setShadowPkgs solverSettingShadowPkgs++      . setStrongFlags solverSettingStrongFlags++      . setAllowBootLibInstalls solverSettingAllowBootLibInstalls++      . setOnlyConstrained solverSettingOnlyConstrained++      . setSolverVerbosity verbosity++        --TODO: [required eventually] decide if we need to prefer+        -- installed for global packages, or prefer latest even for+        -- global packages. Perhaps should be configurable but with a+        -- different name than "upgrade-dependencies".+      . setPreferenceDefault PreferLatestForSelected+                           {-(if solverSettingUpgradeDeps+                                then PreferAllLatest+                                else PreferLatestForSelected)-}++      . removeLowerBounds solverSettingAllowOlder+      . removeUpperBounds solverSettingAllowNewer++      . addDefaultSetupDependencies (defaultSetupDeps comp platform+                                   . PD.packageDescription+                                   . srcpkgDescription)++      . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint+      . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | PackageVersionConstraint name ver <- solverSettingPreferences ]++      . addConstraints+          -- version constraints from the config file or command line+            [ LabeledPackageConstraint (userToPackageConstraint pc) src+            | (pc, src) <- solverSettingConstraints ]++      . addPreferences+          -- enable stanza preference where the user did not specify+          [ PackageStanzasPreference pkgname stanzas+          | pkg <- localPackages+          , let pkgname = pkgSpecifierTarget pkg+                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable+                stanzas = [ stanza | stanza <- [minBound..maxBound]+                          , Map.lookup stanza stanzaM == Nothing ]+          , not (null stanzas)+          ]++      . addConstraints+          -- enable stanza constraints where the user asked to enable+          [ LabeledPackageConstraint+              (PackageConstraint (scopeToplevel pkgname)+                                 (PackagePropertyStanzas stanzas))+              ConstraintSourceConfigFlagOrTarget+          | pkg <- localPackages+          , let pkgname = pkgSpecifierTarget pkg+                stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable+                stanzas = [ stanza | stanza <- [minBound..maxBound]+                          , Map.lookup stanza stanzaM == Just True ]+          , not (null stanzas)+          ]++      . addConstraints+          --TODO: [nice to have] should have checked at some point that the+          -- package in question actually has these flags.+          [ LabeledPackageConstraint+              (PackageConstraint (scopeToplevel pkgname)+                                 (PackagePropertyFlags flags))+              ConstraintSourceConfigFlagOrTarget+          | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]++      . addConstraints+          --TODO: [nice to have] we have user-supplied flags for unspecified+          -- local packages (as well as specific per-package flags). For the+          -- former we just apply all these flags to all local targets which+          -- is silly. We should check if the flags are appropriate.+          [ LabeledPackageConstraint+              (PackageConstraint (scopeToplevel pkgname)+                                 (PackagePropertyFlags flags))+              ConstraintSourceConfigFlagOrTarget+          | let flags = solverSettingFlagAssignment+          , not (PD.nullFlagAssignment flags)+          , pkg <- localPackages+          , let pkgname = pkgSpecifierTarget pkg ]++      $ stdResolverParams++    stdResolverParams =+      -- Note: we don't use the standardInstallPolicy here, since that uses+      -- its own addDefaultSetupDependencies that is not appropriate for us.+      basicInstallPolicy+        installedPkgIndex sourcePkgDb+        localPackages++    -- While we can talk to older Cabal versions (we need to be able to+    -- do so for custom Setup scripts that require older Cabal lib+    -- versions), we have problems talking to some older versions that+    -- don't support certain features.+    --+    -- For example, Cabal-1.16 and older do not know about build targets.+    -- Even worse, 1.18 and older only supported the --constraint flag+    -- with source package ids, not --dependency with installed package+    -- ids. That is bad because we cannot reliably select the right+    -- dependencies in the presence of multiple instances (i.e. the+    -- store). See issue #3932. So we require Cabal 1.20 as a minimum.+    --+    -- Moreover, lib:Cabal generally only supports the interface of+    -- current and past compilers; in fact recent lib:Cabal versions+    -- will warn when they encounter a too new or unknown GHC compiler+    -- version (c.f. #415). To avoid running into unsupported+    -- configurations we encode the compatibility matrix as lower+    -- bounds on lib:Cabal here (effectively corresponding to the+    -- respective major Cabal version bundled with the respective GHC+    -- release).+    --+    -- GHC 9.0   needs  Cabal >= 3.4+    -- GHC 8.10  needs  Cabal >= 3.2+    -- GHC 8.8   needs  Cabal >= 3.0+    -- GHC 8.6   needs  Cabal >= 2.4+    -- GHC 8.4   needs  Cabal >= 2.2+    -- GHC 8.2   needs  Cabal >= 2.0+    -- GHC 8.0   needs  Cabal >= 1.24+    -- GHC 7.10  needs  Cabal >= 1.22+    --+    -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is+    -- the absolute lower bound)+    --+    -- TODO: long-term, this compatibility matrix should be+    --       stored as a field inside 'Distribution.Compiler.Compiler'+    setupMinCabalVersionConstraint+      | isGHC, compVer >= mkVersion [9,0]  = mkVersion [3,4]+      | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2]+      | isGHC, compVer >= mkVersion [8,8]  = mkVersion [3,0]+      | isGHC, compVer >= mkVersion [8,6]  = mkVersion [2,4]+      | isGHC, compVer >= mkVersion [8,4]  = mkVersion [2,2]+      | isGHC, compVer >= mkVersion [8,2]  = mkVersion [2,0]+      | isGHC, compVer >= mkVersion [8,0]  = mkVersion [1,24]+      | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22]+      | otherwise                          = mkVersion [1,20]+      where+        isGHC    = compFlav `elem` [GHC,GHCJS]+        compFlav = compilerFlavor comp+        compVer  = compilerVersion comp++    -- As we can't predict the future, we also place a global upper+    -- bound on the lib:Cabal version we know how to interact with:+    --+    -- The upper bound is computed by incrementing the current major+    -- version twice in order to allow for the current version, as+    -- well as the next adjacent major version (one of which will not+    -- be released, as only "even major" versions of Cabal are+    -- released to Hackage or bundled with proper GHC releases).+    --+    -- For instance, if the current version of cabal-install is an odd+    -- development version, e.g.  Cabal-2.1.0.0, then we impose an+    -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a+    -- stable/release even version, e.g. Cabal-2.2.1.0, the upper+    -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility+    -- when dealing with development snapshots of Cabal and cabal-install.+    --+    setupMaxCabalVersionConstraint =+      alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion++------------------------------------------------------------------------------+-- * Install plan post-processing+------------------------------------------------------------------------------++-- This phase goes from the InstallPlan we get from the solver and has to+-- make an elaborated install plan.+--+-- We go in two steps:+--+--  1. elaborate all the source packages that the solver has chosen.+--  2. swap source packages for pre-existing installed packages wherever+--     possible.+--+-- We do it in this order, elaborating and then replacing, because the easiest+-- way to calculate the installed package ids used for the replacement step is+-- from the elaborated configuration for each package.+++++------------------------------------------------------------------------------+-- * Install plan elaboration+------------------------------------------------------------------------------++-- Note [SolverId to ConfiguredId]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Dependency solving is a per package affair, so after we're done, we+-- end up with 'SolverInstallPlan' that records in 'solverPkgLibDeps'+-- and 'solverPkgExeDeps' what packages provide the libraries and executables+-- needed by each component of the package (phew!)  For example, if I have+--+--      library+--          build-depends: lib+--          build-tool-depends: pkg:exe1+--          build-tools: alex+--+-- After dependency solving, I find out that this library component has+-- library dependencies on lib-0.2, and executable dependencies on pkg-0.1+-- and alex-0.3 (other components of the package may have different+-- dependencies).  Note that I've "lost" the knowledge that I depend+-- *specifically* on the exe1 executable from pkg.+--+-- So, we have a this graph of packages, and we need to transform it into+-- a graph of components which we are actually going to build.  In particular:+--+-- NODE changes from PACKAGE (SolverPackage) to COMPONENTS (ElaboratedConfiguredPackage)+-- EDGE changes from PACKAGE DEP (SolverId) to COMPONENT DEPS (ConfiguredId)+--+-- In both cases, what was previously a single node/edge may turn into multiple+-- nodes/edges.  Multiple components, because there may be multiple components+-- in a package; multiple component deps, because we may depend upon multiple+-- executables from the same package (and maybe, some day, multiple libraries+-- from the same package.)+--+-- Let's talk about how to do this transformation. Naively, we might consider+-- just processing each package, converting it into (zero or) one or more+-- components.  But we also have to update the edges; this leads to+-- two complications:+--+--      1. We don't know what the ConfiguredId of a component is until+--      we've configured it, but we cannot configure a component unless+--      we know the ConfiguredId of all its dependencies.  Thus, we must+--      process the 'SolverInstallPlan' in topological order.+--+--      2. When we process a package, we know the SolverIds of its+--      dependencies, but we have to do some work to turn these into+--      ConfiguredIds.  For example, in the case of build-tool-depends, the+--      SolverId isn't enough to uniquely determine the ConfiguredId we should+--      elaborate to: we have to look at the executable name attached to+--      the package name in the package description to figure it out.+--      At the same time, we NEED to use the SolverId, because there might+--      be multiple versions of the same package in the build plan+--      (due to setup dependencies); we can't just look up the package name+--      from the package description.+--+-- We can adopt the following strategy:+--+--      * When a package is transformed into components, record+--        a mapping from SolverId to ALL of the components+--        which were elaborated.+--+--      * When we look up an edge, we use our knowledge of the+--        component name to *filter* the list of components into+--        the ones we actually wanted to refer to.+--+-- By the way, we can tell that SolverInstallPlan is not the "right" type+-- because a SolverId cannot adequately represent all possible dependency+-- solver states: we may need to record foo-0.1 multiple times in+-- the solver install plan with different dependencies.  This imprecision in the+-- type currently doesn't cause any problems because the dependency solver+-- continues to enforce the single instance restriction regardless of compiler+-- version.  The right way to solve this is to come up with something very much+-- like a 'ConfiguredId', in that it incorporates the version choices of its+-- dependencies, but less fine grained.+++-- | Produce an elaborated install plan using the policy for local builds with+-- a nix-style shared store.+--+-- In theory should be able to make an elaborated install plan with a policy+-- matching that of the classic @cabal install --user@ or @--global@+--+elaborateInstallPlan+  :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb+  -> DistDirLayout+  -> StoreDirLayout+  -> SolverInstallPlan+  -> [PackageSpecifier (SourcePackage (PackageLocation loc))]+  -> Map PackageId PackageSourceHash+  -> InstallDirs.InstallDirTemplates+  -> ProjectConfigShared+  -> PackageConfig+  -> PackageConfig+  -> Map PackageName PackageConfig+  -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)+elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB+                     distDirLayout@DistDirLayout{..}+                     storeDirLayout@StoreDirLayout{storePackageDBStack}+                     solverPlan localPackages+                     sourcePackageHashes+                     defaultInstallDirs+                     sharedPackageConfig+                     allPackagesConfig+                     localPackagesConfig+                     perPackageConfig = do+    x <- elaboratedInstallPlan+    return (x, elaboratedSharedConfig)+  where+    elaboratedSharedConfig =+      ElaboratedSharedConfig {+        pkgConfigPlatform      = platform,+        pkgConfigCompiler      = compiler,+        pkgConfigCompilerProgs = compilerprogdb,+        pkgConfigReplOptions   = []+      }++    preexistingInstantiatedPkgs =+        Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))+      where+        f (SolverInstallPlan.PreExisting inst)+            | let ipkg = instSolverPkgIPI inst+            , not (IPI.indefinite ipkg)+            = Just (IPI.installedUnitId ipkg,+                     (FullUnitId (IPI.installedComponentId ipkg)+                                 (Map.fromList (IPI.instantiatedWith ipkg))))+        f _ = Nothing++    elaboratedInstallPlan =+      flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->+        case planpkg of+          SolverInstallPlan.PreExisting pkg ->+            return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]++          SolverInstallPlan.Configured  pkg ->+            let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace"+                            | otherwise                  = Disp.empty+            in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+>+                             quotes (pretty (packageId pkg))) $+               map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg++    -- NB: We don't INSTANTIATE packages at this point.  That's+    -- a post-pass.  This makes it simpler to compute dependencies.+    elaborateSolverToComponents+        :: (SolverId -> [ElaboratedPlanPackage])+        -> SolverPackage UnresolvedPkgLoc+        -> LogProgress [ElaboratedConfiguredPackage]+    elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0)+        = case mkComponentsGraph (elabEnabledSpec elab0) pd of+           Right g -> do+            let src_comps = componentsGraphToList g+            infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon)+                            4 (dispComponentsWithDeps src_comps)+            (_, comps) <- mapAccumM buildComponent+                            (Map.empty, Map.empty, Map.empty)+                            (map fst src_comps)+            let not_per_component_reasons = why_not_per_component src_comps+            if null not_per_component_reasons+                then return comps+                else do checkPerPackageOk comps not_per_component_reasons+                        return [elaborateSolverToPackage spkg g $+                                comps ++ maybeToList setupComponent]+           Left cns ->+            dieProgress $+                hang (text "Dependency cycle between the following components:") 4+                     (vcat (map (text . componentNameStanza) cns))+      where+        -- You are eligible to per-component build if this list is empty+        why_not_per_component g+            = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage+          where+            cuz reason = [text reason]+            -- We have to disable per-component for now with+            -- Configure-type scripts in order to prevent parallel+            -- invocation of the same `./configure` script.+            -- See https://github.com/haskell/cabal/issues/4548+            --+            -- Moreoever, at this point in time, only non-Custom setup scripts+            -- are supported.  Implementing per-component builds with+            -- Custom would require us to create a new 'ElabSetup'+            -- type, and teach all of the code paths how to handle it.+            -- Once you've implemented this, swap it for the code below.+            cuz_buildtype =+                case PD.buildType (elabPkgDescription elab0) of+                    PD.Configure -> cuz "build-type is Configure"+                    PD.Custom -> cuz "build-type is Custom"+                    _         -> []+            -- cabal-format versions prior to 1.8 have different build-depends semantics+            -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8+            -- see, https://github.com/haskell/cabal/issues/4121+            cuz_spec+                | PD.specVersion pd >= CabalSpecV1_8 = []+                | otherwise = cuz "cabal-version is less than 1.8"+            -- In the odd corner case that a package has no components at all+            -- then keep it as a whole package, since otherwise it turns into+            -- 0 component graph nodes and effectively vanishes. We want to+            -- keep it around at least for error reporting purposes.+            cuz_length+                | length g > 0 = []+                | otherwise    = cuz "there are no buildable components"+            -- For ease of testing, we let per-component builds be toggled+            -- at the top level+            cuz_flag+                | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig)+                = []+                | otherwise = cuz "you passed --disable-per-component"+            -- Enabling program coverage introduces odd runtime dependencies+            -- between components.+            cuz_coverage+                | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig)+                = cuz "program coverage is enabled"+                | otherwise = []++        -- | Sometimes a package may make use of features which are only+        -- supported in per-package mode.  If this is the case, we should+        -- give an error when this occurs.+        checkPerPackageOk comps reasons = do+            let is_sublib (CLibName (LSubLibName _)) = True+                is_sublib _ = False+            when (any (matchElabPkg is_sublib) comps) $+                dieProgress $+                    text "Internal libraries only supported with per-component builds." $$+                    text "Per-component builds were disabled because" <+>+                        fsep (punctuate comma reasons)+            -- TODO: Maybe exclude Backpack too++        elab0 = elaborateSolverToCommon spkg+        pkgid = elabPkgSourceId    elab0+        pd    = elabPkgDescription elab0++        -- TODO: This is just a skeleton to get elaborateSolverToPackage+        -- working correctly+        -- TODO: When we actually support building these components, we+        -- have to add dependencies on this from all other components+        setupComponent :: Maybe ElaboratedConfiguredPackage+        setupComponent+            | PD.buildType (elabPkgDescription elab0) == PD.Custom+            = Just elab0 {+                elabModuleShape = emptyModuleShape,+                elabUnitId = notImpl "elabUnitId",+                elabComponentId = notImpl "elabComponentId",+                elabLinkedInstantiatedWith = Map.empty,+                elabInstallDirs = notImpl "elabInstallDirs",+                elabPkgOrComp = ElabComponent (ElaboratedComponent {..})+              }+            | otherwise+            = Nothing+          where+            compSolverName      = CD.ComponentSetup+            compComponentName   = Nothing+            dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0+            compLibDependencies+                = map configuredId dep_pkgs+            compLinkedLibDependencies = notImpl "compLinkedLibDependencies"+            compOrderLibDependencies = notImpl "compOrderLibDependencies"+            -- Not supported:+            compExeDependencies         = []+            compExeDependencyPaths      = []+            compPkgConfigDependencies   = []++            notImpl f =+                error $ "Distribution.Client.ProjectPlanning.setupComponent: " +++                        f ++ " not implemented yet"+++        buildComponent+            :: (ConfiguredComponentMap,+                LinkedComponentMap,+                Map ComponentId FilePath)+            -> Cabal.Component+            -> LogProgress+                ((ConfiguredComponentMap,+                  LinkedComponentMap,+                  Map ComponentId FilePath),+                ElaboratedConfiguredPackage)+        buildComponent (cc_map, lc_map, exe_map) comp =+          addProgressCtx (text "In the stanza" <+>+                          quotes (text (componentNameStanza cname))) $ do++            -- 1. Configure the component, but with a place holder ComponentId.+            cc0 <- toConfiguredComponent+                    pd+                    (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later")+                    (Map.unionWith Map.union external_lib_cc_map cc_map)+                    (Map.unionWith Map.union external_exe_cc_map cc_map)+                    comp+++            -- 2. Read out the dependencies from the ConfiguredComponent cc0+            let compLibDependencies =+                    -- Nub because includes can show up multiple times+                    ordNub (map (annotatedIdToConfiguredId . ci_ann_id)+                                (cc_includes cc0))+                compExeDependencies =+                    map annotatedIdToConfiguredId+                        (cc_exe_deps cc0)+                compExeDependencyPaths =+                    [ (annotatedIdToConfiguredId aid', path)+                    | aid' <- cc_exe_deps cc0+                    , Just paths <- [Map.lookup (ann_id aid') exe_map1]+                    , path <- paths ]+                elab_comp = ElaboratedComponent {..}++            -- 3. Construct a preliminary ElaboratedConfiguredPackage,+            -- and use this to compute the component ID.  Fix up cc_id+            -- correctly.+            let elab1 = elab0 {+                        elabPkgOrComp = ElabComponent $ elab_comp+                     }+                cid = case elabBuildStyle elab0 of+                        BuildInplaceOnly ->+                          mkComponentId $+                            prettyShow pkgid ++ "-inplace" +++                              (case Cabal.componentNameString cname of+                                  Nothing -> ""+                                  Just s -> "-" ++ prettyShow s)+                        BuildAndInstall ->+                          hashedInstalledPackageId+                            (packageHashInputs+                                elaboratedSharedConfig+                                elab1) -- knot tied+                cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) }+            infoProgress $ dispConfiguredComponent cc++            -- 4. Perform mix-in linking+            let lookup_uid def_uid =+                    case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of+                        Just full -> full+                        Nothing -> error ("lookup_uid: " ++ prettyShow def_uid)+            lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0)+                        (Map.union external_lc_map lc_map) cc+            infoProgress $ dispLinkedComponent lc+            -- NB: elab is setup to be the correct form for an+            -- indefinite library, or a definite library with no holes.+            -- We will modify it in 'instantiateInstallPlan' to handle+            -- instantiated packages.++            -- 5. Construct the final ElaboratedConfiguredPackage+            let+                elab2 = elab1 {+                    elabModuleShape = lc_shape lc,+                    elabUnitId      = abstractUnitId (lc_uid lc),+                    elabComponentId = lc_cid lc,+                    elabLinkedInstantiatedWith = Map.fromList (lc_insts lc),+                    elabPkgOrComp = ElabComponent $ elab_comp {+                        compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)),+                        compOrderLibDependencies =+                          ordNub (map (abstractUnitId . ci_id)+                                      (lc_includes lc ++ lc_sig_includes lc))+                      }+                   }+                elab = elab2 {+                    elabInstallDirs = computeInstallDirs+                      storeDirLayout+                      defaultInstallDirs+                      elaboratedSharedConfig+                      elab2+                   }++            -- 6. Construct the updated local maps+            let cc_map'  = extendConfiguredComponentMap cc cc_map+                lc_map'  = extendLinkedComponentMap lc lc_map+                exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map++            return ((cc_map', lc_map', exe_map'), elab)+          where+            compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"+            compOrderLibDependencies = error "buildComponent: compOrderLibDependencies"++            cname = Cabal.componentName comp+            compComponentName = Just cname+            compSolverName = CD.componentNameToComponent cname++            -- NB: compLinkedLibDependencies and+            -- compOrderLibDependencies are defined when we define+            -- 'elab'.+            external_lib_dep_sids = CD.select (== compSolverName) deps0+            external_exe_dep_sids = CD.select (== compSolverName) exe_deps0++            external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids++            -- Combine library and build-tool dependencies, for backwards+            -- compatibility (See issue #5412 and the documentation for+            -- InstallPlan.fromSolverInstallPlan), but prefer the versions+            -- specified as build-tools.+            external_exe_dep_pkgs =+                concatMap mapDep $+                ordNubBy (pkgName . packageId) $+                external_exe_dep_sids ++ external_lib_dep_sids++            external_exe_map = Map.fromList $+                [ (getComponentId pkg, paths)+                | pkg <- external_exe_dep_pkgs+                , let paths = planPackageExePaths pkg ]+            exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map++            external_lib_cc_map = Map.fromListWith Map.union+                                $ map mkCCMapping external_lib_dep_pkgs+            external_exe_cc_map = Map.fromListWith Map.union+                                $ map mkCCMapping external_exe_dep_pkgs+            external_lc_map =+                Map.fromList $ map mkShapeMapping $+                external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids++            compPkgConfigDependencies =+                [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! "+                                            ++ prettyShow pn ++ " from "+                                            ++ prettyShow (elabPkgSourceId elab0))+                                 (pkgConfigDbPkgVersion pkgConfigDB pn))+                | PkgconfigDependency pn _ <- PD.pkgconfigDepends+                                                (Cabal.componentBuildInfo comp) ]++            inplace_bin_dir elab =+                binDirectoryFor+                    distDirLayout+                    elaboratedSharedConfig+                    elab $+                    case Cabal.componentNameString cname of+                             Just n -> prettyShow n+                             Nothing -> ""+++    -- | Given a 'SolverId' referencing a dependency on a library, return+    -- the 'ElaboratedPlanPackage' corresponding to the library.  This+    -- returns at most one result.+    elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage])+                         -> SolverId -> [ElaboratedPlanPackage]+    elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep++    -- | Given an 'ElaboratedPlanPackage', return the paths to where the+    -- executables that this package represents would be installed.+    -- The only case where multiple paths can be returned is the inplace+    -- monolithic package one, since there can be multiple exes and each one+    -- has its own directory.+    planPackageExePaths :: ElaboratedPlanPackage -> [FilePath]+    planPackageExePaths =+        -- Pre-existing executables are assumed to be in PATH+        -- already.  In fact, this should be impossible.+        InstallPlan.foldPlanPackage (const []) $ \elab ->+            let+              executables :: [FilePath]+              executables =+                case elabPkgOrComp elab of+                    -- Monolithic mode: all exes of the package+                    ElabPackage _ -> unUnqualComponentName . PD.exeName+                                 <$> PD.executables (elabPkgDescription elab)+                    -- Per-component mode: just the selected exe+                    ElabComponent comp ->+                        case fmap Cabal.componentNameString+                                  (compComponentName comp) of+                            Just (Just n) -> [prettyShow n]+                            _ -> [""]+            in+              binDirectoryFor+                 distDirLayout+                 elaboratedSharedConfig+                 elab+                 <$> executables++    elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc+                             -> ComponentsGraph+                             -> [ElaboratedConfiguredPackage]+                             -> ElaboratedConfiguredPackage+    elaborateSolverToPackage+        pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride)+                           _flags _stanzas _deps0 _exe_deps0)+        compGraph comps =+        -- Knot tying: the final elab includes the+        -- pkgInstalledId, which is calculated by hashing many+        -- of the other fields of the elaboratedPackage.+        elab+      where+        elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg+        elab1 = elab0 {+                elabUnitId = newSimpleUnitId pkgInstalledId,+                elabComponentId = pkgInstalledId,+                elabLinkedInstantiatedWith = Map.empty,+                elabPkgOrComp = ElabPackage $ ElaboratedPackage {..},+                elabModuleShape = modShape+            }+        elab = elab1 {+                elabInstallDirs =+                  computeInstallDirs storeDirLayout+                                     defaultInstallDirs+                                     elaboratedSharedConfig+                                     elab1+            }++        modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of+                        Nothing -> emptyModuleShape+                        Just e -> Ty.elabModuleShape e++        pkgInstalledId+          | shouldBuildInplaceOnly pkg+          = mkComponentId (prettyShow pkgid ++ "-inplace")++          | otherwise+          = assert (isJust elabPkgSourceHash) $+            hashedInstalledPackageId+              (packageHashInputs+                elaboratedSharedConfig+                elab)  -- recursive use of elab++          | otherwise+          = error $ "elaborateInstallPlan: non-inplace package "+                 ++ " is missing a source hash: " ++ prettyShow pkgid++        -- Need to filter out internal dependencies, because they don't+        -- correspond to anything real anymore.+        isExt confid = confSrcId confid /= pkgid+        filterExt  = filter isExt+        filterExt' = filter (isExt . fst)++        pkgLibDependencies+            = buildComponentDeps (filterExt  . compLibDependencies)+        pkgExeDependencies+            = buildComponentDeps (filterExt  . compExeDependencies)+        pkgExeDependencyPaths+            = buildComponentDeps (filterExt' . compExeDependencyPaths)+        -- TODO: Why is this flat?+        pkgPkgConfigDependencies+            = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies++        pkgDependsOnSelfLib+            = CD.fromList [ (CD.componentNameToComponent cn, [()])+                          | Graph.N _ cn _ <- fromMaybe [] mb_closure ]+          where+            mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ]+            -- NB: the sublib case should not occur, because sub-libraries+            -- are not supported without per-component builds+            is_lib (CLibName _) = True+            is_lib _ = False++        buildComponentDeps f+            = CD.fromList [ (compSolverName comp, f comp)+                          | ElaboratedConfiguredPackage{+                                elabPkgOrComp = ElabComponent comp+                            } <- comps+                          ]++        -- NB: This is not the final setting of 'pkgStanzasEnabled'.+        -- See [Sticky enabled testsuites]; we may enable some extra+        -- stanzas opportunistically when it is cheap to do so.+        --+        -- However, we start off by enabling everything that was+        -- requested, so that we can maintain an invariant that+        -- pkgStanzasEnabled is a superset of elabStanzasRequested+        pkgStanzasEnabled  = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested++    elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc+                            -> ElaboratedConfiguredPackage+    elaborateSolverToCommon+        pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride)+                           flags stanzas deps0 _exe_deps0) =+        elaboratedPackage+      where+        elaboratedPackage = ElaboratedConfiguredPackage {..}++        -- These get filled in later+        elabUnitId          = error "elaborateSolverToCommon: elabUnitId"+        elabComponentId     = error "elaborateSolverToCommon: elabComponentId"+        elabInstantiatedWith = Map.empty+        elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith"+        elabPkgOrComp       = error "elaborateSolverToCommon: elabPkgOrComp"+        elabInstallDirs     = error "elaborateSolverToCommon: elabInstallDirs"+        elabModuleShape     = error "elaborateSolverToCommon: elabModuleShape"++        elabIsCanonical     = True+        elabPkgSourceId     = pkgid+        elabPkgDescription  = case PD.finalizePD+                                    flags elabEnabledSpec (const True)+                                    platform (compilerInfo compiler)+                                    [] gdesc of+                               Right (desc, _) -> desc+                               Left _          -> error "Failed to finalizePD in elaborateSolverToCommon"+        elabFlagAssignment  = flags+        elabFlagDefaults    = PD.mkFlagAssignment+                              [ (Cabal.flagName flag, Cabal.flagDefault flag)+                              | flag <- PD.genPackageFlags gdesc ]++        elabEnabledSpec      = enableStanzas stanzas+        elabStanzasAvailable = stanzas++        elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)+        elabStanzasRequested = optStanzaTabulate $ \o -> case o of+            -- NB: even if a package stanza is requested, if the package+            -- doesn't actually have any of that stanza we omit it from+            -- the request, to ensure that we don't decide that this+            -- package needs to be rebuilt.  (It needs to be done here,+            -- because the ElaboratedConfiguredPackage is where we test+            -- whether or not there have been changes.)+            TestStanzas  -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ] +            BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ]+          where+            tests, benchmarks :: Maybe Bool+            tests      = perPkgOptionMaybe pkgid packageConfigTests+            benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks++        -- This is a placeholder which will get updated by 'pruneInstallPlanPass1'+        -- and 'pruneInstallPlanPass2'.  We can't populate it here+        -- because whether or not tests/benchmarks should be enabled+        -- is heuristically calculated based on whether or not the+        -- dependencies of the test suite have already been installed,+        -- but this function doesn't know what is installed (since+        -- we haven't improved the plan yet), so we do it in another pass.+        -- Check the comments of those functions for more details.+        elabConfigureTargets = []+        elabBuildTargets    = []+        elabTestTargets     = []+        elabBenchTargets    = []+        elabReplTarget      = Nothing+        elabHaddockTargets  = []++        elabBuildHaddocks   =+          perPkgOptionFlag pkgid False packageConfigDocumentation++        elabPkgSourceLocation = srcloc+        elabPkgSourceHash   = Map.lookup pkgid sourcePackageHashes+        elabLocalToProject  = isLocalToProject pkg+        elabBuildStyle      = if shouldBuildInplaceOnly pkg+                                then BuildInplaceOnly else BuildAndInstall+        elabBuildPackageDBStack    = buildAndRegisterDbs+        elabRegisterPackageDBStack = buildAndRegisterDbs++        elabSetupScriptStyle       = packageSetupScriptStyle elabPkgDescription+        elabSetupScriptCliVersion  =+          packageSetupScriptSpecVersion+          elabSetupScriptStyle elabPkgDescription libDepGraph deps0+        elabSetupPackageDBStack    = buildAndRegisterDbs++        elabInplaceBuildPackageDBStack = inplacePackageDbs+        elabInplaceRegisterPackageDBStack = inplacePackageDbs+        elabInplaceSetupPackageDBStack = inplacePackageDbs++        buildAndRegisterDbs+          | shouldBuildInplaceOnly pkg = inplacePackageDbs+          | otherwise                  = storePackageDbs++        elabPkgDescriptionOverride = descOverride++        elabVanillaLib    = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively+        elabSharedLib     = pkgid `Set.member` pkgsUseSharedLibrary+        elabStaticLib     = perPkgOptionFlag pkgid False packageConfigStaticLib+        elabDynExe        = perPkgOptionFlag pkgid False packageConfigDynExe+        elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe+        elabGHCiLib       = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still++        elabProfExe       = perPkgOptionFlag pkgid False packageConfigProf+        elabProfLib       = pkgid `Set.member` pkgsUseProfilingLibrary++        (elabProfExeDetail,+         elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault+                               packageConfigProfDetail+                               packageConfigProfLibDetail+        elabCoverage      = perPkgOptionFlag pkgid False packageConfigCoverage++        elabOptimization  = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization+        elabSplitObjs     = perPkgOptionFlag pkgid False packageConfigSplitObjs+        elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections+        elabStripLibs     = perPkgOptionFlag pkgid False packageConfigStripLibs+        elabStripExes     = perPkgOptionFlag pkgid False packageConfigStripExes+        elabDebugInfo     = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo++        -- Combine the configured compiler prog settings with the user-supplied+        -- config. For the compiler progs any user-supplied config was taken+        -- into account earlier when configuring the compiler so its ok that+        -- our configured settings for the compiler override the user-supplied+        -- config here.+        elabProgramPaths  = Map.fromList+                             [ (programId prog, programPath prog)+                             | prog <- configuredPrograms compilerprogdb ]+                        <> perPkgOptionMapLast pkgid packageConfigProgramPaths+        elabProgramArgs   = Map.fromList+                             [ (programId prog, args)+                             | prog <- configuredPrograms compilerprogdb+                             , let args = programOverrideArgs prog+                             , not (null args)+                             ]+                        <> perPkgOptionMapMappend pkgid packageConfigProgramArgs+        elabProgramPathExtra    = perPkgOptionNubList pkgid packageConfigProgramPathExtra+        elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs+        elabExtraLibDirs        = perPkgOptionList pkgid packageConfigExtraLibDirs+        elabExtraFrameworkDirs  = perPkgOptionList pkgid packageConfigExtraFrameworkDirs+        elabExtraIncludeDirs    = perPkgOptionList pkgid packageConfigExtraIncludeDirs+        elabProgPrefix          = perPkgOptionMaybe pkgid packageConfigProgPrefix+        elabProgSuffix          = perPkgOptionMaybe pkgid packageConfigProgSuffix+++        elabHaddockHoogle       = perPkgOptionFlag pkgid False packageConfigHaddockHoogle+        elabHaddockHtml         = perPkgOptionFlag pkgid False packageConfigHaddockHtml+        elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation+        elabHaddockForeignLibs  = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs+        elabHaddockForHackage   = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage+        elabHaddockExecutables  = perPkgOptionFlag pkgid False packageConfigHaddockExecutables+        elabHaddockTestSuites   = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites+        elabHaddockBenchmarks   = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks+        elabHaddockInternal     = perPkgOptionFlag pkgid False packageConfigHaddockInternal+        elabHaddockCss          = perPkgOptionMaybe pkgid packageConfigHaddockCss+        elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource+        elabHaddockQuickJump    = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump+        elabHaddockHscolourCss  = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss+        elabHaddockContents     = perPkgOptionMaybe pkgid packageConfigHaddockContents++        elabTestMachineLog      = perPkgOptionMaybe pkgid packageConfigTestMachineLog+        elabTestHumanLog        = perPkgOptionMaybe pkgid packageConfigTestHumanLog+        elabTestShowDetails     = perPkgOptionMaybe pkgid packageConfigTestShowDetails+        elabTestKeepTix         = perPkgOptionFlag pkgid False packageConfigTestKeepTix+        elabTestWrapper         = perPkgOptionMaybe pkgid packageConfigTestWrapper+        elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites+        elabTestTestOptions     = perPkgOptionList pkgid packageConfigTestTestOptions++        elabBenchmarkOptions    = perPkgOptionList pkgid packageConfigBenchmarkOptions++    perPkgOptionFlag  :: PackageId -> a ->  (PackageConfig -> Flag a) -> a+    perPkgOptionMaybe :: PackageId ->       (PackageConfig -> Flag a) -> Maybe a+    perPkgOptionList  :: PackageId ->       (PackageConfig -> [a])    -> [a]++    perPkgOptionFlag  pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)+    perPkgOptionMaybe pkgid     f = flagToMaybe (lookupPerPkgOption pkgid f)+    perPkgOptionList  pkgid     f = lookupPerPkgOption pkgid f+    perPkgOptionNubList    pkgid f = fromNubList   (lookupPerPkgOption pkgid f)+    perPkgOptionMapLast    pkgid f = getMapLast    (lookupPerPkgOption pkgid f)+    perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f)++    perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)+      where+        exe = fromFlagOrDefault def bothflag+        lib = fromFlagOrDefault def (bothflag <> libflag)++        bothflag = lookupPerPkgOption pkgid fboth+        libflag  = lookupPerPkgOption pkgid flib++    lookupPerPkgOption :: (Package pkg, Monoid m)+                       => pkg -> (PackageConfig -> m) -> m+    lookupPerPkgOption pkg f =+        -- This is where we merge the options from the project config that+        -- apply to all packages, all project local packages, and to specific+        -- named packages+        global `mappend` local `mappend` perpkg+      where+        global = f allPackagesConfig+        local  | isLocalToProject pkg+               = f localPackagesConfig+               | otherwise+               = mempty+        perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)++    inplacePackageDbs = storePackageDbs+                     ++ [ distPackageDB (compilerId compiler) ]++    storePackageDbs   = storePackageDBStack (compilerId compiler)++    -- For this local build policy, every package that lives in a local source+    -- dir (as opposed to a tarball), or depends on such a package, will be+    -- built inplace into a shared dist dir. Tarball packages that depend on+    -- source dir packages will also get unpacked locally.+    shouldBuildInplaceOnly :: SolverPackage loc -> Bool+    shouldBuildInplaceOnly pkg = Set.member (packageId pkg)+                                            pkgsToBuildInplaceOnly++    pkgsToBuildInplaceOnly :: Set PackageId+    pkgsToBuildInplaceOnly =+        Set.fromList+      $ map packageId+      $ SolverInstallPlan.reverseDependencyClosure+          solverPlan+          (map PlannedId (Set.toList pkgsLocalToProject))++    isLocalToProject :: Package pkg => pkg -> Bool+    isLocalToProject pkg = Set.member (packageId pkg)+                                      pkgsLocalToProject++    pkgsLocalToProject :: Set PackageId+    pkgsLocalToProject =+        Set.fromList (catMaybes (map shouldBeLocal localPackages))+        --TODO: localPackages is a misnomer, it's all project packages+        -- here is where we decide which ones will be local!++    pkgsUseSharedLibrary :: Set PackageId+    pkgsUseSharedLibrary =+        packagesWithLibDepsDownwardClosedProperty needsSharedLib+      where+        needsSharedLib pkg =+            fromMaybe compilerShouldUseSharedLibByDefault+                      (liftM2 (||) pkgSharedLib pkgDynExe)+          where+            pkgid        = packageId pkg+            pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib+            pkgDynExe    = perPkgOptionMaybe pkgid packageConfigDynExe++    --TODO: [code cleanup] move this into the Cabal lib. It's currently open+    -- coded in Distribution.Simple.Configure, but should be made a proper+    -- function of the Compiler or CompilerInfo.+    compilerShouldUseSharedLibByDefault =+      case compilerFlavor compiler of+        GHC   -> GHC.isDynamic compiler+        GHCJS -> GHCJS.isDynamic compiler+        _     -> False++    pkgsUseProfilingLibrary :: Set PackageId+    pkgsUseProfilingLibrary =+        packagesWithLibDepsDownwardClosedProperty needsProfilingLib+      where+        needsProfilingLib pkg =+            fromFlagOrDefault False (profBothFlag <> profLibFlag)+          where+            pkgid        = packageId pkg+            profBothFlag = lookupPerPkgOption pkgid packageConfigProf+            profLibFlag  = lookupPerPkgOption pkgid packageConfigProfLib+            --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe++    libDepGraph = Graph.fromDistinctList $+                    map NonSetupLibDepSolverPlanPackage+                        (SolverInstallPlan.toList solverPlan)++    packagesWithLibDepsDownwardClosedProperty property =+        Set.fromList+      . map packageId+      . fromMaybe []+      $ Graph.closure+          libDepGraph+          [ Graph.nodeKey pkg+          | pkg <- SolverInstallPlan.toList solverPlan+          , property pkg ] -- just the packages that satisfy the property+      --TODO: [nice to have] this does not check the config consistency,+      -- e.g. a package explicitly turning off profiling, but something+      -- depending on it that needs profiling. This really needs a separate+      -- package config validation/resolution pass.++      --TODO: [nice to have] config consistency checking:+      -- + profiling libs & exes, exe needs lib, recursive+      -- + shared libs & exes, exe needs lib, recursive+      -- + vanilla libs & exes, exe needs lib, recursive+      -- + ghci or shared lib needed by TH, recursive, ghc version dependent++-- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping++shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId+shouldBeLocal NamedPackage{}              = Nothing+shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of+    LocalUnpackedPackage _ -> Just (packageId pkg)+    _                      -> Nothing++-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'.+matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool+matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p)++-- | Get the appropriate 'ComponentName' which identifies an installed+-- component.+ipiComponentName :: IPI.InstalledPackageInfo -> ComponentName+ipiComponentName = CLibName . IPI.sourceLibName++-- | Given a 'ElaboratedConfiguredPackage', report if it matches a+-- 'ComponentName'.+matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool+matchElabPkg p elab =+    case elabPkgOrComp elab of+        ElabComponent comp -> maybe False p (compComponentName comp)+        ElabPackage _ ->+            -- So, what should we do here?  One possibility is to+            -- unconditionally return 'True', because whatever it is+            -- that we're looking for, it better be in this package.+            -- But this is a bit dodgy if the package doesn't actually+            -- have, e.g., a library.  Fortunately, it's not possible+            -- for the build of the library/executables to be toggled+            -- by 'pkgStanzasEnabled', so the only thing we have to+            -- test is if the component in question is *buildable.*+            any (p . componentName)+                (Cabal.pkgBuildableComponents (elabPkgDescription elab))++-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName'+-- and 'ComponentName' to the 'ComponentId' that should be used+-- in this case.+mkCCMapping :: ElaboratedPlanPackage+            -> (PackageName, Map ComponentName (AnnotatedId ComponentId))+mkCCMapping =+    InstallPlan.foldPlanPackage+       (\ipkg -> (packageName ipkg,+                    Map.singleton (ipiComponentName ipkg)+                                  -- TODO: libify+                                  (AnnotatedId {+                                    ann_id = IPI.installedComponentId ipkg,+                                    ann_pid = packageId ipkg,+                                    ann_cname = IPI.sourceComponentName ipkg+                                  })))+      $ \elab ->+        let mk_aid cn = AnnotatedId {+                            ann_id = elabComponentId elab,+                            ann_pid = packageId elab,+                            ann_cname = cn+                        }+        in (packageName elab,+            case elabPkgOrComp elab of+                ElabComponent comp ->+                    case compComponentName comp of+                        Nothing -> Map.empty+                        Just n  -> Map.singleton n (mk_aid n)+                ElabPackage _ ->+                    Map.fromList $+                        map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn))+                            (Cabal.pkgBuildableComponents (elabPkgDescription elab)))++-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId'+-- to the shape of this package, as per mix-in linking.+mkShapeMapping :: ElaboratedPlanPackage+               -> (ComponentId, (OpenUnitId, ModuleShape))+mkShapeMapping dpkg =+    (getComponentId dpkg, (indef_uid, shape))+  where+    (dcid, shape) =+        InstallPlan.foldPlanPackage+            -- Uses Monad (->)+            (liftM2 (,) IPI.installedComponentId shapeInstalledPackage)+            (liftM2 (,) elabComponentId elabModuleShape)+            dpkg+    indef_uid =+        IndefFullUnitId dcid+            (Map.fromList [ (req, OpenModuleVar req)+                          | req <- Set.toList (modShapeRequires shape)])++-- | Get the bin\/ directories that a package's executables should reside in.+--+-- The result may be empty if the package does not build any executables.+--+-- The result may have several entries if this is an inplace build of a package+-- with multiple executables.+binDirectories+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedConfiguredPackage+  -> [FilePath]+binDirectories layout config package = case elabBuildStyle package of+  -- quick sanity check: no sense returning a bin directory if we're not going+  -- to put any executables in it, that will just clog up the PATH+  _ | noExecutables -> []+  BuildAndInstall -> [installedBinDirectory package]+  BuildInplaceOnly -> map (root</>) $ case elabPkgOrComp package of+    ElabComponent comp -> case compSolverName comp of+      CD.ComponentExe n -> [prettyShow n]+      _ -> []+    ElabPackage _ -> map (prettyShow . PD.exeName)+                   . PD.executables+                   . elabPkgDescription+                   $ package+  where+  noExecutables = null . PD.executables . elabPkgDescription $ package+  root  =  distBuildDirectory layout (elabDistDirParams config package)+       </> "build"++-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the+-- dependency graph considers only dependencies on libraries which are+-- NOT from setup dependencies.  Used to compute the set+-- of packages needed for profiling and dynamic libraries.+newtype NonSetupLibDepSolverPlanPackage+    = NonSetupLibDepSolverPlanPackage+    { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage }++instance Package NonSetupLibDepSolverPlanPackage where+    packageId = packageId . unNonSetupLibDepSolverPlanPackage++instance IsNode NonSetupLibDepSolverPlanPackage where+    type Key NonSetupLibDepSolverPlanPackage = SolverId+    nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage+    nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg)+        = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg)++type InstS = Map UnitId ElaboratedPlanPackage+type InstM a = State InstS a++getComponentId :: ElaboratedPlanPackage+               -> ComponentId+getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg+getComponentId (InstallPlan.Configured elab) = elabComponentId elab+getComponentId (InstallPlan.Installed elab) = elabComponentId elab++extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage+                      -> BuildStyle+extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab+extractElabBuildStyle _ = BuildAndInstall++-- instantiateInstallPlan is responsible for filling out an InstallPlan+-- with all of the extra Configured packages that would be generated by+-- recursively instantiating the dependencies of packages.+--+-- Suppose we are compiling the following packages:+--+--  unit f where+--    signature H+--+--  unit g where+--    dependency f[H=containers:Data.Map]+--+-- At entry, we have an InstallPlan with a single plan package per+-- actual source package, e.g., only (indefinite!) f and g.  The job of+-- instantiation is to turn this into three plan packages: each of the+-- packages as before, but also a new, definite package f[H=containers:Data.Map]+--+-- How do we do this?  The general strategy is to iterate over every+-- package in the existing plan and recursively create new entries for+-- each of its dependencies which is an instantiated package (e.g.,+-- f[H=p:G]).  This process must be recursive, as f itself may depend on+-- OTHER packages which it instantiated using its hole H.+--+-- Some subtleties:+--+--  * We have to keep track of whether or not we are instantiating with+--    inplace packages, because instantiating a non-inplace package with+--    an inplace packages makes it inplace (since it depends on+--    something in the inplace store)!  The rule is that if any of the+--    modules in an instantiation are inplace, then the instantiated+--    unit itself must be inplace.  There is then a bunch of faffing+--    about to keep track of BuildStyle.+--+--  * ElaboratedConfiguredPackage was never really designed for post+--    facto instantiation, so some of the steps for generating new+--    instantiations are a little fraught.  For example, the act of+--    flipping a package to be inplace involves faffing about with four+--    fields, because these fields are precomputed.  A good refactor+--    would be to reduce the amount of precomputation to simplify the+--    algorithm here.+--+--  * We use the state monad to cache already instantiated modules, so+--    we don't instantiate the same thing multiple times.+--+instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan+instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =+    InstallPlan.new (IndependentGoals False)+                    (Graph.fromDistinctList (Map.elems ready_map))+  where+    pkgs = InstallPlan.toList plan++    cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ]++    instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle)+                      -> InstM (DefUnitId, BuildStyle)+    instantiateUnitId cid insts = state $ \s ->+        case Map.lookup uid s of+            Nothing ->+                -- Knot tied+                -- TODO: I don't think the knot tying actually does+                -- anything useful+                let (r, s') = runState (instantiateComponent uid cid insts)+                                       (Map.insert uid r s)+                in ((def_uid, extractElabBuildStyle r), Map.insert uid r s')+            Just r -> ((def_uid, extractElabBuildStyle r), s)+      where+        def_uid = mkDefUnitId cid (fmap fst insts)+        uid = unDefUnitId def_uid++    -- No need to InplaceT; the inplace-ness is properly computed for+    -- the ElaboratedPlanPackage, so that will implicitly pass it on+    instantiateComponent+        :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle)+        -> InstM ElaboratedPlanPackage+    instantiateComponent uid cid insts+      | Just planpkg <- Map.lookup cid cmap+      = case planpkg of+          InstallPlan.Configured (elab0@ElaboratedConfiguredPackage+                                    { elabPkgOrComp = ElabComponent comp }) -> do+            deps <-+              traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)+            let build_style = fold (fmap snd insts)+            let getDep (Module dep_uid _) = [dep_uid]+                elab1 = fixupBuildStyle build_style $ elab0 {+                    elabUnitId = uid,+                    elabComponentId = cid,+                    elabInstantiatedWith = fmap fst insts,+                    elabIsCanonical = Map.null (fmap fst insts),+                    elabPkgOrComp = ElabComponent comp {+                        compOrderLibDependencies =+                            (if Map.null insts then [] else [newSimpleUnitId cid]) +++                            ordNub (map unDefUnitId+                                (deps ++ concatMap (getDep . fst) (Map.elems insts)))+                    }+                  }+                elab = elab1 {+                    elabInstallDirs = computeInstallDirs storeDirLayout+                                                         defaultInstallDirs+                                                         elaboratedShared+                                                         elab1+                  }+            return $ InstallPlan.Configured elab+          _ -> return planpkg+      | otherwise = error ("instantiateComponent: " ++ prettyShow cid)++    substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle)+    substUnitId _ (DefiniteUnitId uid) =+        -- This COULD actually, secretly, be an inplace package, but in+        -- that case it doesn't matter as it's already been recorded+        -- in the package that depends on this+        return (uid, BuildAndInstall)+    substUnitId subst (IndefFullUnitId cid insts) = do+        insts' <- substSubst subst insts+        instantiateUnitId cid insts'++    -- NB: NOT composition+    substSubst :: Map ModuleName (Module, BuildStyle)+               -> Map ModuleName OpenModule+               -> InstM (Map ModuleName (Module, BuildStyle))+    substSubst subst insts = traverse (substModule subst) insts++    substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle)+    substModule subst (OpenModuleVar mod_name)+        | Just m <- Map.lookup mod_name subst = return m+        | otherwise = error "substModule: non-closing substitution"+    substModule subst (OpenModule uid mod_name) = do+        (uid', build_style) <- substUnitId subst uid+        return (Module uid' mod_name, build_style)++    indefiniteUnitId :: ComponentId -> InstM UnitId+    indefiniteUnitId cid = do+        let uid = newSimpleUnitId cid+        r <- indefiniteComponent uid cid+        state $ \s -> (uid, Map.insert uid r s)++    indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage+    indefiniteComponent _uid cid+      -- Only need Configured; this phase happens before improvement, so+      -- there shouldn't be any Installed packages here.+      | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap+      , ElabComponent elab_comp <- elabPkgOrComp epkg+      = do -- We need to do a little more processing of the includes: some+           -- of them are fully definite even without substitution.  We+           -- want to build those too; see #5634.+           --+           -- This code mimics similar code in Distribution.Backpack.ReadyComponent;+           -- however, unlike the conversion from LinkedComponent to+           -- ReadyComponent, this transformation is done *without*+           -- changing the type in question; and what we are simply+           -- doing is enforcing tighter invariants on the data+           -- structure in question.  The new invariant is that there+           -- is no IndefFullUnitId in compLinkedLibDependencies that actually+           -- has no holes.  We couldn't specify this invariant when+           -- we initially created the ElaboratedPlanPackage because+           -- we have no way of actually reifying the UnitId into a+           -- DefiniteUnitId (that's what substUnitId does!)+           new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->+             if Set.null (openUnitIdFreeHoles uid)+                then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid)+                else return uid+           -- NB: no fixupBuildStyle needed here, as if the indefinite+           -- component depends on any inplace packages, it itself must+           -- be indefinite!  There is no substitution here, we can't+           -- post facto add inplace deps+           return . InstallPlan.Configured $ epkg {+            elabPkgOrComp = ElabComponent elab_comp {+                compLinkedLibDependencies = new_deps,+                -- I think this is right: any new definite unit ids we+                -- minted in the phase above need to be built before us.+                -- Add 'em in.  This doesn't remove any old dependencies+                -- on the indefinite package; they're harmless.+                compOrderLibDependencies =+                    ordNub $ compOrderLibDependencies elab_comp +++                             [unDefUnitId d | DefiniteUnitId d <- new_deps]+            }+           }+      | Just planpkg <- Map.lookup cid cmap+      = return planpkg+      | otherwise = error ("indefiniteComponent: " ++ prettyShow cid)++    fixupBuildStyle BuildAndInstall elab = elab+    fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab+    fixupBuildStyle BuildInplaceOnly elab = elab {+      elabBuildStyle = BuildInplaceOnly,+      elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab,+      elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab,+      elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab+    }++    ready_map = execState work Map.empty++    work = for_ pkgs $ \pkg ->+            case pkg of+                InstallPlan.Configured elab+                    | not (Map.null (elabLinkedInstantiatedWith elab))+                    -> indefiniteUnitId (elabComponentId elab)+                        >> return ()+                _ -> instantiateUnitId (getComponentId pkg) Map.empty+                        >> return ()++---------------------------+-- Build targets+--++-- Refer to ProjectPlanning.Types for details of these important types:++-- data ComponentTarget = ...+-- data SubComponentTarget = ...++-- One step in the build system is to translate higher level intentions like+-- "build this package", "test that package", or "repl that component" into+-- a more detailed specification of exactly which components to build (or other+-- actions like repl or build docs). This translation is somewhat different for+-- different commands. For example "test" for a package will build a different+-- set of components than "build". In addition, the translation of these+-- intentions can fail. For example "run" for a package is only unambiguous+-- when the package has a single executable.+--+-- So we need a little bit of infrastructure to make it easy for the command+-- implementations to select what component targets are meant when a user asks+-- to do something with a package or component. To do this (and to be able to+-- produce good error messages for mistakes and when targets are not available)+-- we need to gather and summarise accurate information about all the possible+-- targets, both available and unavailable. Then a command implementation can+-- decide which of the available component targets should be selected.++-- | An available target represents a component within a package that a user+-- command could plausibly refer to. In this sense, all the components defined+-- within the package are things the user could refer to, whether or not it+-- would actually be possible to build that component.+--+-- In particular the available target contains an 'AvailableTargetStatus' which+-- informs us about whether it's actually possible to select this component to+-- be built, and if not why not. This detail makes it possible for command+-- implementations (like @build@, @test@ etc) to accurately report why a target+-- cannot be used.+--+-- Note that the type parameter is used to help enforce that command+-- implementations can only select targets that can actually be built (by+-- forcing them to return the @k@ value for the selected targets).+-- In particular 'resolveTargets' makes use of this (with @k@ as+-- @('UnitId', ComponentName')@) to identify the targets thus selected.+--+data AvailableTarget k = AvailableTarget {+       availableTargetPackageId      :: PackageId,+       availableTargetComponentName  :: ComponentName,+       availableTargetStatus         :: AvailableTargetStatus k,+       availableTargetLocalToProject :: Bool+     }+  deriving (Eq, Show, Functor)++-- | The status of a an 'AvailableTarget' component. This tells us whether+-- it's actually possible to select this component to be built, and if not+-- why not.+--+data AvailableTargetStatus k =+       TargetDisabledByUser   -- ^ When the user does @tests: False@+     | TargetDisabledBySolver -- ^ When the solver could not enable tests+     | TargetNotBuildable     -- ^ When the component has @buildable: False@+     | TargetNotLocal         -- ^ When the component is non-core in a non-local package+     | TargetBuildable k TargetRequested -- ^ The target can or should be built+  deriving (Eq, Ord, Show, Functor)++-- | This tells us whether a target ought to be built by default, or only if+-- specifically requested. The policy is that components like libraries and+-- executables are built by default by @build@, but test suites and benchmarks+-- are not, unless this is overridden in the project configuration.+--+data TargetRequested =+       TargetRequestedByDefault    -- ^ To be built by default+     | TargetNotRequestedByDefault -- ^ Not to be built by default+  deriving (Eq, Ord, Show)++-- | Given the install plan, produce the set of 'AvailableTarget's for each+-- package-component pair.+--+-- Typically there will only be one such target for each component, but for+-- example if we have a plan with both normal and profiling variants of a+-- component then we would get both as available targets, or similarly if we+-- had a plan that contained two instances of the same version of a package.+-- This approach makes it relatively easy to select all instances\/variants+-- of a component.+--+availableTargets :: ElaboratedInstallPlan+                 -> Map (PackageId, ComponentName)+                        [AvailableTarget (UnitId, ComponentName)]+availableTargets installPlan =+    let rs = [ (pkgid, cname, fake, target)+             | pkg <- InstallPlan.toList installPlan+             , (pkgid, cname, fake, target) <- case pkg of+                 InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg+                 InstallPlan.Installed   elab -> availableSourceTargets elab+                 InstallPlan.Configured  elab -> availableSourceTargets elab+             ]+     in Map.union+         (Map.fromListWith (++)+            [ ((pkgid, cname), [target])+            | (pkgid, cname, fake, target) <- rs, not fake])+         (Map.fromList+            [ ((pkgid, cname), [target])+            | (pkgid, cname, fake, target) <- rs, fake])+    -- The normal targets mask the fake ones. We get all instances of the+    -- normal ones and only one copy of the fake ones (as there are many+    -- duplicates of the fake ones). See 'availableSourceTargets' below for+    -- more details on this fake stuff is about.++availableInstalledTargets :: IPI.InstalledPackageInfo+                          -> [(PackageId, ComponentName, Bool,+                               AvailableTarget (UnitId, ComponentName))]+availableInstalledTargets ipkg =+    let unitid = installedUnitId ipkg+        cname  = CLibName LMainLibName+        status = TargetBuildable (unitid, cname) TargetRequestedByDefault+        target = AvailableTarget (packageId ipkg) cname status False+        fake   = False+     in [(packageId ipkg, cname, fake, target)]++availableSourceTargets :: ElaboratedConfiguredPackage+                       -> [(PackageId, ComponentName, Bool,+                            AvailableTarget (UnitId, ComponentName))]+availableSourceTargets elab =+    -- We have a somewhat awkward problem here. We need to know /all/ the+    -- components from /all/ the packages because these are the things that+    -- users could refer to. Unfortunately, at this stage the elaborated install+    -- plan does /not/ contain all components: some components have already+    -- been deleted because they cannot possibly be built. This is the case+    -- for components that are marked @buildable: False@ in their .cabal files.+    -- (It's not unreasonable that the unbuildable components have been pruned+    -- as the plan invariant is considerably simpler if all nodes can be built)+    --+    -- We can recover the missing components but it's not exactly elegant. For+    -- a graph node corresponding to a component we still have the information+    -- about the package that it came from, and this includes the names of+    -- /all/ the other components in the package. So in principle this lets us+    -- find the names of all components, plus full details of the buildable+    -- components.+    --+    -- Consider for example a package with 3 exe components: foo, bar and baz+    -- where foo and bar are buildable, but baz is not. So the plan contains+    -- nodes for the components foo and bar. Now we look at each of these two+    -- nodes and look at the package they come from and the names of the+    -- components in this package. This will give us the names foo, bar and+    -- baz, twice (once for each of the two buildable components foo and bar).+    --+    -- We refer to these reconstructed missing components as fake targets.+    -- It is an invariant that they are not available to be built.+    --+    -- To produce the final set of targets we put the fake targets in a finite+    -- map (thus eliminating the duplicates) and then we overlay that map with+    -- the normal buildable targets. (This is done above in 'availableTargets'.)+    --+    [ (packageId elab, cname, fake, target)+    | component <- pkgComponents (elabPkgDescription elab)+    , let cname  = componentName component+          status = componentAvailableTargetStatus component+          target = AvailableTarget {+                     availableTargetPackageId      = packageId elab,+                     availableTargetComponentName  = cname,+                     availableTargetStatus         = status,+                     availableTargetLocalToProject = elabLocalToProject elab+                   }+          fake   = isFakeTarget cname++    -- TODO: The goal of this test is to exclude "instantiated"+    -- packages as available targets. This means that you can't+    -- ask for a particular instantiated component to be built;+    -- it will only get built by a dependency.  Perhaps the+    -- correct way to implement this is to run selection+    -- prior to instantiating packages.  If you refactor+    -- this, then you can delete this test.+    , elabIsCanonical elab++      -- Filter out some bogus parts of the cross product that are never needed+    , case status of+        TargetBuildable{} | fake -> False+        _                        -> True+    ]+  where+    isFakeTarget cname =+      case elabPkgOrComp elab of+        ElabPackage _               -> False+        ElabComponent elabComponent -> compComponentName elabComponent+                                       /= Just cname++    componentAvailableTargetStatus+      :: Component -> AvailableTargetStatus (UnitId, ComponentName)+    componentAvailableTargetStatus component =+        case componentOptionalStanza $ CD.componentNameToComponent cname of+          -- it is not an optional stanza, so a library, exe or foreign lib+          Nothing+            | not buildable  -> TargetNotBuildable+            | otherwise      -> TargetBuildable (elabUnitId elab, cname)+                                                TargetRequestedByDefault++          -- it is not an optional stanza, so a testsuite or benchmark+          Just stanza ->+            case (optStanzaLookup stanza (elabStanzasRequested elab), -- TODO+                  optStanzaSetMember stanza (elabStanzasAvailable elab)) of+              _ | not withinPlan -> TargetNotLocal+              (Just False,   _)  -> TargetDisabledByUser+              (Nothing,  False)  -> TargetDisabledBySolver+              _ | not buildable  -> TargetNotBuildable+              (Just True, True)  -> TargetBuildable (elabUnitId elab, cname)+                                                    TargetRequestedByDefault+              (Nothing,   True)  -> TargetBuildable (elabUnitId elab, cname)+                                                    TargetNotRequestedByDefault+              (Just True, False) ->+                error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname+      where+        cname      = componentName component+        buildable  = PD.buildable (componentBuildInfo component)+        withinPlan = elabLocalToProject elab+                  || case elabPkgOrComp elab of+                       ElabComponent elabComponent ->+                         compComponentName elabComponent == Just cname+                       ElabPackage _ ->+                         case componentName component of+                           CLibName (LMainLibName) -> True+                           CExeName _ -> True+                           --TODO: what about sub-libs and foreign libs?+                           _          -> False++-- | Merge component targets that overlap each other. Specially when we have+-- multiple targets for the same component and one of them refers to the whole+-- component (rather than a module or file within) then all the other targets+-- for that component are subsumed.+--+-- We also allow for information associated with each component target, and+-- whenever we targets subsume each other we aggregate their associated info.+--+nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, [a])]+nubComponentTargets =+    concatMap (wholeComponentOverrides . map snd)+  . groupBy ((==)    `on` fst)+  . sortBy  (compare `on` fst)+  . map (\t@((ComponentTarget cname _, _)) -> (cname, t))+  . map compatSubComponentTargets+  where+    -- If we're building the whole component then that the only target all we+    -- need, otherwise we can have several targets within the component.+    wholeComponentOverrides :: [(ComponentTarget,  a )]+                            -> [(ComponentTarget, [a])]+    wholeComponentOverrides ts =+      case [ t | (t@(ComponentTarget _ WholeComponent), _) <- ts ] of+        (t:_) -> [ (t, map snd ts) ]+        []    -> [ (t,[x]) | (t,x) <- ts ]++    -- Not all Cabal Setup.hs versions support sub-component targets, so switch+    -- them over to the whole component+    compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a)+    compatSubComponentTargets target@(ComponentTarget cname _subtarget, x)+      | not setupHsSupportsSubComponentTargets+                  = (ComponentTarget cname WholeComponent, x)+      | otherwise = target++    -- Actually the reality is that no current version of Cabal's Setup.hs+    -- build command actually support building specific files or modules.+    setupHsSupportsSubComponentTargets = False+    -- TODO: when that changes, adjust this test, e.g.+    -- | pkgSetupScriptCliVersion >= Version [x,y] []++pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool+pkgHasEphemeralBuildTargets elab =+    isJust (elabReplTarget elab)+ || (not . null) (elabTestTargets elab)+ || (not . null) (elabBenchTargets elab)+ || (not . null) (elabHaddockTargets elab)+ || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab+                      , subtarget /= WholeComponent ]++-- | The components that we'll build all of, meaning that after they're built+-- we can skip building them again (unlike with building just some modules or+-- other files within a component).+--+elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage+                              -> Set ComponentName+elabBuildTargetWholeComponents elab =+    Set.fromList+      [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ]++++------------------------------------------------------------------------------+-- * Install plan pruning+------------------------------------------------------------------------------++-- | How 'pruneInstallPlanToTargets' should interpret the per-package+-- 'ComponentTarget's: as build, repl or haddock targets.+--+data TargetAction = TargetActionConfigure+                  | TargetActionBuild+                  | TargetActionRepl+                  | TargetActionTest+                  | TargetActionBench+                  | TargetActionHaddock++-- | Given a set of per-package\/per-component targets, take the subset of the+-- install plan needed to build those targets. Also, update the package config+-- to specify which optional stanzas to enable, and which targets within each+-- package to build.+--+-- NB: Pruning happens after improvement, which is important because we+-- will prune differently depending on what is already installed (to+-- implement "sticky" test suite enabling behavior).+--+pruneInstallPlanToTargets :: TargetAction+                          -> Map UnitId [ComponentTarget]+                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan+pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan =+    InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)+  . Graph.fromDistinctList+    -- We have to do the pruning in two passes+  . pruneInstallPlanPass2+  . pruneInstallPlanPass1+    -- Set the targets that will be the roots for pruning+  . setRootTargets targetActionType perPkgTargetsMap+  . InstallPlan.toList+  $ elaboratedPlan++-- | This is a temporary data type, where we temporarily+-- override the graph dependencies of an 'ElaboratedPackage',+-- so we can take a closure over them.  We'll throw out the+-- overriden dependencies when we're done so it's strictly temporary.+--+-- For 'ElaboratedComponent', this the cached unit IDs always+-- coincide with the real thing.+data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId]++instance Package PrunedPackage where+    packageId (PrunedPackage elab _) = packageId elab++instance HasUnitId PrunedPackage where+    installedUnitId = nodeKey++instance IsNode PrunedPackage where+    type Key PrunedPackage = UnitId+    nodeKey (PrunedPackage elab _)  = nodeKey elab+    nodeNeighbors (PrunedPackage _ deps) = deps++fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage+fromPrunedPackage (PrunedPackage elab _) = elab++-- | Set the build targets based on the user targets (but not rev deps yet).+-- This is required before we can prune anything.+--+setRootTargets :: TargetAction+               -> Map UnitId [ComponentTarget]+               -> [ElaboratedPlanPackage]+               -> [ElaboratedPlanPackage]+setRootTargets targetAction perPkgTargetsMap =+    assert (not (Map.null perPkgTargetsMap)) $+    assert (all (not . null) (Map.elems perPkgTargetsMap)) $++    map (mapConfiguredPackage setElabBuildTargets)+  where+    -- Set the targets we'll build for this package/component. This is just+    -- based on the root targets from the user, not targets implied by reverse+    -- dependencies. Those comes in the second pass once we know the rev deps.+    --+    setElabBuildTargets elab =+      case (Map.lookup (installedUnitId elab) perPkgTargetsMap,+            targetAction) of+        (Nothing, _)                      -> elab+        (Just tgts,  TargetActionConfigure) -> elab { elabConfigureTargets = tgts }+        (Just tgts,  TargetActionBuild)   -> elab { elabBuildTargets = tgts }+        (Just tgts,  TargetActionTest)    -> elab { elabTestTargets  = tgts }+        (Just tgts,  TargetActionBench)   -> elab { elabBenchTargets  = tgts }+        (Just [tgt], TargetActionRepl)    -> elab { elabReplTarget = Just tgt+                                                  , elabBuildHaddocks = False }+        (Just tgts,  TargetActionHaddock) ->+          foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts+                                            , elabBuildHaddocks = True }) tgts+        (Just _,     TargetActionRepl)    ->+          error "pruneInstallPlanToTargets: multiple repl targets"++    setElabHaddockTargets tgt elab+      | isTestComponentTarget tgt       = elab { elabHaddockTestSuites  = True }+      | isBenchComponentTarget tgt      = elab { elabHaddockBenchmarks  = True }+      | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True }+      | isExeComponentTarget tgt        = elab { elabHaddockExecutables = True }+      | isSubLibComponentTarget tgt     = elab { elabHaddockInternal    = True }+      | otherwise                       = elab++-- | Assuming we have previously set the root build targets (i.e. the user+-- targets but not rev deps yet), the first pruning pass does two things:+--+-- * A first go at determining which optional stanzas (testsuites, benchmarks)+--   are needed. We have a second go in the next pass.+-- * Take the dependency closure using pruned dependencies. We prune deps that+--   are used only by unneeded optional stanzas. These pruned deps are only+--   used for the dependency closure and are not persisted in this pass.+--+pruneInstallPlanPass1 :: [ElaboratedPlanPackage]+                      -> [ElaboratedPlanPackage]+pruneInstallPlanPass1 pkgs =+    map (mapConfiguredPackage fromPrunedPackage)+        (fromMaybe [] $ Graph.closure graph roots)+  where+    pkgs' = map (mapConfiguredPackage prune) pkgs+    graph = Graph.fromDistinctList pkgs'+    roots = mapMaybe find_root pkgs'++    prune elab = PrunedPackage elab' (pruneOptionalDependencies elab')+      where elab' =+                setDocumentation+              $ addOptionalStanzas elab++    is_root :: PrunedPackage -> Maybe UnitId+    is_root (PrunedPackage elab _) =+      if not $ and [ null (elabConfigureTargets elab)+                   , null (elabBuildTargets elab)+                   , null (elabTestTargets elab)+                   , null (elabBenchTargets elab)+                   , isNothing (elabReplTarget elab)+                   , null (elabHaddockTargets elab)+                   ]+          then Just (installedUnitId elab)+          else Nothing++    find_root (InstallPlan.Configured pkg) = is_root pkg+    -- When using the extra-packages stanza we need to+    -- look at installed packages as well.+    find_root (InstallPlan.Installed pkg)  = is_root pkg+    find_root _ = Nothing++    -- Note [Sticky enabled testsuites]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- The testsuite and benchmark targets are somewhat special in that we need+    -- to configure the packages with them enabled, and we need to do that even+    -- if we only want to build one of several testsuites.+    --+    -- There are two cases in which we will enable the testsuites (or+    -- benchmarks): if one of the targets is a testsuite, or if all of the+    -- testsuite dependencies are already cached in the store. The rationale+    -- for the latter is to minimise how often we have to reconfigure due to+    -- the particular targets we choose to build. Otherwise choosing to build+    -- a testsuite target, and then later choosing to build an exe target+    -- would involve unnecessarily reconfiguring the package with testsuites+    -- disabled. Technically this introduces a little bit of stateful+    -- behaviour to make this "sticky", but it should be benign.++    -- Decide whether or not to enable testsuites and benchmarks.+    -- See [Sticky enabled testsuites]+    addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage+    addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =+        elab {+            elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas })+        }+      where+        stanzas :: OptionalStanzaSet+               -- By default, we enabled all stanzas requested by the user,+               -- as per elabStanzasRequested, done in+               -- 'elaborateSolverToPackage'+        stanzas = pkgStanzasEnabled pkg+               -- optionalStanzasRequiredByTargets has to be done at+               -- prune-time because it depends on 'elabTestTargets'+               -- et al, which is done by 'setRootTargets' at the+               -- beginning of pruning.+               <> optionalStanzasRequiredByTargets elab+               -- optionalStanzasWithDepsAvailable has to be done at+               -- prune-time because it depends on what packages are+               -- installed, which is not known until after improvement+               -- (pruning is done after improvement)+               <> optionalStanzasWithDepsAvailable availablePkgs elab pkg+    addOptionalStanzas elab = elab++    setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage+    setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } =+      elab {+        elabBuildHaddocks =+            elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab+      }++      where+        documentationEnabled c =+          case c of+            CD.ComponentLib      -> const True+            CD.ComponentSubLib _ -> elabHaddockInternal+            CD.ComponentFLib _   -> elabHaddockForeignLibs+            CD.ComponentExe _    -> elabHaddockExecutables+            CD.ComponentTest _   -> elabHaddockTestSuites+            CD.ComponentBench _  -> elabHaddockBenchmarks+            CD.ComponentSetup    -> const False++    setDocumentation elab = elab++    -- Calculate package dependencies but cut out those needed only by+    -- optional stanzas that we've determined we will not enable.+    -- These pruned deps are not persisted in this pass since they're based on+    -- the optional stanzas and we'll make further tweaks to the optional+    -- stanzas in the next pass.+    --+    pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId]+    pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ }+        = InstallPlan.depends elab -- no pruning+    pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg }+        = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)+      where+        keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `optStanzaSetMember` stanzas+        keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas+        keepNeeded _                     _ = True+        stanzas = pkgStanzasEnabled pkg++    optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage+                                     -> OptionalStanzaSet+    optionalStanzasRequiredByTargets pkg =+      optStanzaSetFromList+        [ stanza+        | ComponentTarget cname _ <- elabBuildTargets pkg+                                  ++ elabTestTargets pkg+                                  ++ elabBenchTargets pkg+                                  ++ maybeToList (elabReplTarget pkg)+                                  ++ elabHaddockTargets pkg+        , stanza <- maybeToList $+                    componentOptionalStanza $+                    CD.componentNameToComponent cname+        ]++    availablePkgs =+      Set.fromList+        [ installedUnitId pkg+        | InstallPlan.PreExisting pkg <- pkgs ]++-- | Given a set of already installed packages @availablePkgs@,+-- determine the set of available optional stanzas from @pkg@+-- which have all of their dependencies already installed.  This is used+-- to implement "sticky" testsuites, where once we have installed+-- all of the deps needed for the test suite, we go ahead and+-- enable it always.+optionalStanzasWithDepsAvailable :: Set UnitId+                                 -> ElaboratedConfiguredPackage+                                 -> ElaboratedPackage+                                 -> OptionalStanzaSet+optionalStanzasWithDepsAvailable availablePkgs elab pkg =+    optStanzaSetFromList+      [ stanza+      | stanza <- optStanzaSetToList (elabStanzasAvailable elab)+      , let deps :: [UnitId]+            deps = CD.select (optionalStanzaDeps stanza)+                             -- TODO: probably need to select other+                             -- dep types too eventually+                             (pkgOrderDependencies pkg)+      , all (`Set.member` availablePkgs) deps+      ]+  where+    optionalStanzaDeps TestStanzas  (CD.ComponentTest  _) = True+    optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True+    optionalStanzaDeps _            _                     = False+++-- The second pass does three things:+--+-- * A second go at deciding which optional stanzas to enable.+-- * Prune the dependencies based on the final choice of optional stanzas.+-- * Extend the targets within each package to build, now we know the reverse+--   dependencies, ie we know which libs are needed as deps by other packages.+--+-- Achieving sticky behaviour with enabling\/disabling optional stanzas is+-- tricky. The first approximation was handled by the first pass above, but+-- it's not quite enough. That pass will enable stanzas if all of the deps+-- of the optional stanza are already installed /in the store/. That's important+-- but it does not account for dependencies that get built inplace as part of+-- the project. We cannot take those inplace build deps into account in the+-- pruning pass however because we don't yet know which ones we're going to+-- build. Once we do know, we can have another go and enable stanzas that have+-- all their deps available. Now we can consider all packages in the pruned+-- plan to be available, including ones we already decided to build from+-- source.+--+-- Deciding which targets to build depends on knowing which packages have+-- reverse dependencies (ie are needed). This requires the result of first+-- pass, which is another reason we have to split it into two passes.+--+-- Note that just because we might enable testsuites or benchmarks (in the+-- first or second pass) doesn't mean that we build all (or even any) of them.+-- That depends on which targets we picked in the first pass.+--+pruneInstallPlanPass2 :: [ElaboratedPlanPackage]+                      -> [ElaboratedPlanPackage]+pruneInstallPlanPass2 pkgs =+    map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs+  where+    setStanzasDepsAndTargets elab =+        elab {+          elabBuildTargets = ordNub+                           $ elabBuildTargets elab+                          ++ libTargetsRequiredForRevDeps+                          ++ exeTargetsRequiredForRevDeps,+          elabPkgOrComp =+            case elabPkgOrComp elab of+              ElabPackage pkg ->+                let stanzas = pkgStanzasEnabled pkg+                           <> optionalStanzasWithDepsAvailable availablePkgs elab pkg+                    keepNeeded (CD.ComponentTest  _) _ = TestStanzas  `optStanzaSetMember` stanzas+                    keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas+                    keepNeeded _                     _ = True+                in ElabPackage $ pkg {+                  pkgStanzasEnabled = stanzas,+                  pkgLibDependencies   = CD.filterDeps keepNeeded (pkgLibDependencies pkg),+                  pkgExeDependencies   = CD.filterDeps keepNeeded (pkgExeDependencies pkg),+                  pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg)+                }+              r@(ElabComponent _) -> r+        }+      where+        libTargetsRequiredForRevDeps =+          [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent+          | installedUnitId elab `Set.member` hasReverseLibDeps+          ]+        exeTargetsRequiredForRevDeps =+          -- TODO: allow requesting executable with different name+          -- than package name+          [ ComponentTarget (Cabal.CExeName+                             $ packageNameToUnqualComponentName+                             $ packageName $ elabPkgSourceId elab)+                            WholeComponent+          | installedUnitId elab `Set.member` hasReverseExeDeps+          ]+++    availablePkgs :: Set UnitId+    availablePkgs = Set.fromList (map installedUnitId pkgs)++    hasReverseLibDeps :: Set UnitId+    hasReverseLibDeps =+      Set.fromList [ depid+                   | InstallPlan.Configured pkg <- pkgs+                   , depid <- elabOrderLibDependencies pkg ]++    hasReverseExeDeps :: Set UnitId+    hasReverseExeDeps =+      Set.fromList [ depid+                   | InstallPlan.Configured pkg <- pkgs+                   , depid <- elabOrderExeDependencies pkg ]++mapConfiguredPackage :: (srcpkg -> srcpkg')+                     -> InstallPlan.GenericPlanPackage ipkg srcpkg+                     -> InstallPlan.GenericPlanPackage ipkg srcpkg'+mapConfiguredPackage f (InstallPlan.Configured pkg) =+  InstallPlan.Configured (f pkg)+mapConfiguredPackage f (InstallPlan.Installed pkg) =+  InstallPlan.Installed (f pkg)+mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =+  InstallPlan.PreExisting pkg++------------------------------------+-- Support for --only-dependencies+--++-- | Try to remove the given targets from the install plan.+--+-- This is not always possible.+--+pruneInstallPlanToDependencies :: Set UnitId+                               -> ElaboratedInstallPlan+                               -> Either CannotPruneDependencies+                                         ElaboratedInstallPlan+pruneInstallPlanToDependencies pkgTargets installPlan =+    assert (all (isJust . InstallPlan.lookup installPlan)+                (Set.toList pkgTargets)) $++    fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))+  . checkBrokenDeps+  . Graph.fromDistinctList+  . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)+  . InstallPlan.toList+  $ installPlan+    where+      -- Our strategy is to remove the packages we don't want and then check+      -- if the remaining graph is broken or not, ie any packages with dangling+      -- dependencies. If there are then we cannot prune the given targets.+      checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage+                      -> Either CannotPruneDependencies+                                (Graph.Graph ElaboratedPlanPackage)+      checkBrokenDeps graph =+        case Graph.broken graph of+          []             -> Right graph+          brokenPackages ->+            Left $ CannotPruneDependencies+             [ (pkg, missingDeps)+             | (pkg, missingDepIds) <- brokenPackages+             , let missingDeps = mapMaybe lookupDep missingDepIds+             ]+            where+              -- lookup in the original unpruned graph+              lookupDep = InstallPlan.lookup installPlan++-- | It is not always possible to prune to only the dependencies of a set of+-- targets. It may be the case that removing a package leaves something else+-- that still needed the pruned package.+--+-- This lists all the packages that would be broken, and their dependencies+-- that would be missing if we did prune.+--+newtype CannotPruneDependencies =+        CannotPruneDependencies [(ElaboratedPlanPackage,+                                  [ElaboratedPlanPackage])]+  deriving (Show)+++---------------------------+-- Setup.hs script policy+--++-- Handling for Setup.hs scripts is a bit tricky, part of it lives in the+-- solver phase, and part in the elaboration phase. We keep the helper+-- functions for both phases together here so at least you can see all of it+-- in one place.+--+-- There are four major cases for Setup.hs handling:+--+--  1. @build-type@ Custom with a @custom-setup@ section+--  2. @build-type@ Custom without a @custom-setup@ section+--  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@+--  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@+--+-- It's also worth noting that packages specifying @cabal-version: >= 1.23@+-- or later that have @build-type@ Custom will always have a @custom-setup@+-- section. Therefore in case 2, the specified @cabal-version@ will always be+-- less than 1.23.+--+-- In cases 1 and 2 we obviously have to build an external Setup.hs script,+-- while in case 4 we can use the internal library API.+--+-- TODO:In case 3 we should fail. We don't know how to talk to+-- newer ./Setup.hs+--+-- data SetupScriptStyle = ...  -- see ProjectPlanning.Types++-- | Work out the 'SetupScriptStyle' given the package description.+--+packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle+packageSetupScriptStyle pkg+  | buildType == PD.Custom+  , Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza+  , not (PD.defaultSetupDepends setupbi)  -- but not one we added internally+  = SetupCustomExplicitDeps++  | buildType == PD.Custom+  , Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as+  , PD.defaultSetupDepends setupbi        -- the solver fills in the deps+  = SetupCustomImplicitDeps++  | buildType == PD.Custom+  , Nothing <- PD.setupBuildInfo pkg      -- we get this case pre-solver+  = SetupCustomImplicitDeps++  -- here we should fail.+  | PD.specVersion pkg > cabalSpecLatest  -- one cabal-install is built against+  = SetupNonCustomExternalLib++  | otherwise+  = SetupNonCustomInternalLib+  where+    buildType = PD.buildType pkg+++-- | Part of our Setup.hs handling policy is implemented by getting the solver+-- to work out setup dependencies for packages. The solver already handles+-- packages that explicitly specify setup dependencies, but we can also tell+-- the solver to treat other packages as if they had setup dependencies.+-- That's what this function does, it gets called by the solver for all+-- packages that don't already have setup dependencies.+--+-- The dependencies we want to add is different for each 'SetupScriptStyle'.+--+-- Note that adding default deps means these deps are actually /added/ to the+-- packages that we get out of the solver in the 'SolverInstallPlan'. Making+-- implicit setup deps explicit is a problem in the post-solver stages because+-- we still need to distinguish the case of explicit and implict setup deps.+-- See 'rememberImplicitSetupDeps'.+--+-- Note in addition to adding default setup deps, we also use+-- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require+-- @Cabal >= 1.20@ for Setup scripts.+--+defaultSetupDeps :: Compiler -> Platform+                 -> PD.PackageDescription+                 -> Maybe [Dependency]+defaultSetupDeps compiler platform pkg =+    case packageSetupScriptStyle pkg of++      -- For packages with build type custom that do not specify explicit+      -- setup dependencies, we add a dependency on Cabal and a number+      -- of other packages.+      SetupCustomImplicitDeps ->+        Just $+        [ Dependency depPkgname anyVersion mainLibSet+        | depPkgname <- legacyCustomSetupPkgs compiler platform ] +++        [ Dependency cabalPkgname cabalConstraint mainLibSet+        | packageName pkg /= cabalPkgname ]+        where+          -- The Cabal dep is slightly special:+          -- * We omit the dep for the Cabal lib itself, since it bootstraps.+          -- * We constrain it to be < 1.25+          --+          -- Note: we also add a global constraint to require Cabal >= 1.20+          -- for Setup scripts (see use addSetupCabalMinVersionConstraint).+          --+          cabalConstraint   = orLaterVersion (csvToVersion (PD.specVersion pkg))+                                `intersectVersionRanges`+                              earlierVersion cabalCompatMaxVer+          -- The idea here is that at some point we will make significant+          -- breaking changes to the Cabal API that Setup.hs scripts use.+          -- So for old custom Setup scripts that do not specify explicit+          -- constraints, we constrain them to use a compatible Cabal version.+          cabalCompatMaxVer = mkVersion [1,25]++      -- For other build types (like Simple) if we still need to compile an+      -- external Setup.hs, it'll be one of the simple ones that only depends+      -- on Cabal and base.+      SetupNonCustomExternalLib ->+        Just [ Dependency cabalPkgname cabalConstraint mainLibSet+             , Dependency basePkgname  anyVersion mainLibSet]+        where+          cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg))++      -- The internal setup wrapper method has no deps at all.+      SetupNonCustomInternalLib -> Just []++      -- This case gets ruled out by the caller, planPackages, see the note+      -- above in the SetupCustomImplicitDeps case.+      SetupCustomExplicitDeps ->+        error $ "defaultSetupDeps: called for a package with explicit "+             ++ "setup deps: " ++ prettyShow (packageId pkg)+  where+    -- we require one less+    --+    -- This maps e.g. CabalSpecV3_0 to mkVersion [2,5]+    csvToVersion :: CabalSpecVersion -> Version+    csvToVersion = mkVersion . cabalSpecMinimumLibraryVersion++-- | Work out which version of the Cabal we will be using to talk to the+-- Setup.hs interface for this package.+--+-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result+-- of what the solver picked for us, based on the explicit setup deps or the+-- ones added implicitly by 'defaultSetupDeps'.+--+packageSetupScriptSpecVersion :: SetupScriptStyle+                              -> PD.PackageDescription+                              -> Graph.Graph NonSetupLibDepSolverPlanPackage+                              -> ComponentDeps [SolverId]+                              -> Version++-- We're going to be using the internal Cabal library, so the spec version of+-- that is simply the version of the Cabal library that cabal-install has been+-- built with.+packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ =+    cabalVersion++-- If we happen to be building the Cabal lib itself then because that+-- bootstraps itself then we use the version of the lib we're building.+packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _+  | packageName pkg == cabalPkgname+  = packageVersion pkg++-- In all other cases we have a look at what version of the Cabal lib the+-- solver picked. Or if it didn't depend on Cabal at all (which is very rare)+-- then we look at the .cabal file to see what spec version it declares.+packageSetupScriptSpecVersion _ pkg libDepGraph deps =+    case find ((cabalPkgname ==) . packageName) setupLibDeps of+      Just dep -> packageVersion dep+      Nothing  -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg))+  where+    setupLibDeps = map packageId $ fromMaybe [] $+                   Graph.closure libDepGraph (CD.setupDeps deps)+++cabalPkgname, basePkgname :: PackageName+cabalPkgname = mkPackageName "Cabal"+basePkgname  = mkPackageName "base"+++legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName]+legacyCustomSetupPkgs compiler (Platform _ os) =+    map mkPackageName $+        [ "array", "base", "binary", "bytestring", "containers"+        , "deepseq", "directory", "filepath", "pretty"+        , "process", "time", "transformers" ]+     ++ [ "Win32" | os == Windows ]+     ++ [ "unix"  | os /= Windows ]+     ++ [ "ghc-prim"         | isGHC ]+     ++ [ "template-haskell" | isGHC ]+     ++ [ "old-time" | notGHC710 ]+  where+    isGHC = compilerCompatFlavor GHC compiler+    notGHC710 = case compilerCompatVersion GHC compiler of+        Nothing -> False+        Just v  -> v <= mkVersion [7,9]++-- The other aspects of our Setup.hs policy lives here where we decide on+-- the 'SetupScriptOptions'.+--+-- Our current policy for the 'SetupCustomImplicitDeps' case is that we+-- try to make the implicit deps cover everything, and we don't allow the+-- compiler to pick up other deps. This may or may not be sustainable, and+-- we might have to allow the deps to be non-exclusive, but that itself would+-- be tricky since we would have to allow the Setup access to all the packages+-- in the store and local dbs.++setupHsScriptOptions :: ElaboratedReadyPackage+                     -> ElaboratedInstallPlan+                     -> ElaboratedSharedConfig+                     -> DistDirLayout+                     -> FilePath+                     -> FilePath+                     -> Bool+                     -> Lock+                     -> SetupScriptOptions+-- TODO: Fix this so custom is a separate component.  Custom can ALWAYS+-- be a separate component!!!+setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..})+                     plan ElaboratedSharedConfig{..} distdir srcdir builddir+                     isParallelBuild cacheLock =+    SetupScriptOptions {+      useCabalVersion          = thisVersion elabSetupScriptCliVersion,+      useCabalSpecVersion      = Just elabSetupScriptCliVersion,+      useCompiler              = Just pkgConfigCompiler,+      usePlatform              = Just pkgConfigPlatform,+      usePackageDB             = elabSetupPackageDBStack,+      usePackageIndex          = Nothing,+      useDependencies          = [ (uid, srcid)+                                 | ConfiguredId srcid (Just (CLibName LMainLibName)) uid+                                 <- elabSetupDependencies elab ],+      useDependenciesExclusive = True,+      useVersionMacros         = elabSetupScriptStyle == SetupCustomExplicitDeps,+      useProgramDb             = pkgConfigCompilerProgs,+      useDistPref              = builddir,+      useLoggingHandle         = Nothing, -- this gets set later+      useWorkingDir            = Just srcdir,+      useExtraPathEnv          = elabExeDependencyPaths elab,+      useExtraEnvOverrides     = dataDirsEnvironmentForPlan distdir plan,+      useWin32CleanHack        = False,   --TODO: [required eventually]+      forceExternalSetupMethod = isParallelBuild,+      setupCacheLock           = Just cacheLock,+      isInteractive            = False+    }+++-- | To be used for the input for elaborateInstallPlan.+--+-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure.+--+userInstallDirTemplates :: Compiler+                        -> IO InstallDirs.InstallDirTemplates+userInstallDirTemplates compiler = do+    InstallDirs.defaultInstallDirs+                  (compilerFlavor compiler)+                  True  -- user install+                  False -- unused++storePackageInstallDirs :: StoreDirLayout+                        -> CompilerId+                        -> InstalledPackageId+                        -> InstallDirs.InstallDirs FilePath+storePackageInstallDirs storeDirLayout compid ipkgid =+  storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid++storePackageInstallDirs' :: StoreDirLayout+                         -> CompilerId+                         -> UnitId+                         -> InstallDirs.InstallDirs FilePath+storePackageInstallDirs' StoreDirLayout{ storePackageDirectory+                                       , storeDirectory }+                         compid unitid =+    InstallDirs.InstallDirs {..}+  where+    store        = storeDirectory compid+    prefix       = storePackageDirectory compid unitid+    bindir       = prefix </> "bin"+    libdir       = prefix </> "lib"+    libsubdir    = ""+    -- Note: on macOS, we place libraries into+    --       @store/lib@ to work around the load+    --       command size limit of macOSs mach-o linker.+    --       See also @PackageHash.hashedInstalledPackageIdVeryShort@+    dynlibdir    | buildOS == OSX = store </> "lib"+                 | otherwise      = libdir+    flibdir      = libdir+    libexecdir   = prefix </> "libexec"+    libexecsubdir= ""+    includedir   = libdir </> "include"+    datadir      = prefix </> "share"+    datasubdir   = ""+    docdir       = datadir </> "doc"+    mandir       = datadir </> "man"+    htmldir      = docdir  </> "html"+    haddockdir   = htmldir+    sysconfdir   = prefix </> "etc"++++computeInstallDirs :: StoreDirLayout+                   -> InstallDirs.InstallDirTemplates+                   -> ElaboratedSharedConfig+                   -> ElaboratedConfiguredPackage+                   -> InstallDirs.InstallDirs FilePath+computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab+  | elabBuildStyle elab == BuildInplaceOnly+  -- use the ordinary default install dirs+  = (InstallDirs.absoluteInstallDirs+       (elabPkgSourceId elab)+       (elabUnitId elab)+       (compilerInfo (pkgConfigCompiler elaboratedShared))+       InstallDirs.NoCopyDest+       (pkgConfigPlatform elaboratedShared)+       defaultInstallDirs) {++      -- absoluteInstallDirs sets these as 'undefined' but we have+      -- to use them as "Setup.hs configure" args+      InstallDirs.libsubdir  = "",+      InstallDirs.libexecsubdir  = "",+      InstallDirs.datasubdir = ""+    }++  | otherwise+  -- use special simplified install dirs+  = storePackageInstallDirs'+      storeDirLayout+      (compilerId (pkgConfigCompiler elaboratedShared))+      (elabUnitId elab)+++--TODO: [code cleanup] perhaps reorder this code+-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,+-- make the various Setup.hs {configure,build,copy} flags+++setupHsConfigureFlags :: ElaboratedReadyPackage+                      -> ElaboratedSharedConfig+                      -> Verbosity+                      -> FilePath+                      -> Cabal.ConfigFlags+setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..})+                      sharedConfig@ElaboratedSharedConfig{..}+                      verbosity builddir =+    sanityCheckElaboratedConfiguredPackage sharedConfig elab+        (Cabal.ConfigFlags {..})+  where+    configArgs                = mempty -- unused, passed via args+    configDistPref            = toFlag builddir+    configCabalFilePath       = mempty+    configVerbosity           = toFlag verbosity++    configInstantiateWith     = Map.toList elabInstantiatedWith++    configDeterministic       = mempty -- doesn't matter, configIPID/configCID overridese+    configIPID                = case elabPkgOrComp of+                                  ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg))+                                  ElabComponent _ -> mempty+    configCID                 = case elabPkgOrComp of+                                  ElabPackage _ -> mempty+                                  ElabComponent _ -> toFlag elabComponentId++    configProgramPaths        = Map.toList elabProgramPaths+    configProgramArgs+        | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True+          -- workaround for <https://github.com/haskell/cabal/issues/4010>+          --+          -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.+          -- custom Setup.hs scripts calling out to GHC even when going via+          -- @runProgram ghcProgram@, as e.g. happy does in its+          -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>+          -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)+          --+          -- So for now, let's pass the rather harmless and idempotent+          -- `-hide-all-packages` flag to all invocations (which has+          -- the benefit that every GHC invocation starts with a+          -- conistently well-defined clean slate) until we find a+          -- better way.+                              = Map.toList $+                                Map.insertWith (++) "ghc" ["-hide-all-packages"]+                                               elabProgramArgs+        | otherwise           = Map.toList elabProgramArgs+    configProgramPathExtra    = toNubList elabProgramPathExtra+    configHcFlavor            = toFlag (compilerFlavor pkgConfigCompiler)+    configHcPath              = mempty -- we use configProgramPaths instead+    configHcPkg               = mempty -- we use configProgramPaths instead++    configVanillaLib          = toFlag elabVanillaLib+    configSharedLib           = toFlag elabSharedLib+    configStaticLib           = toFlag elabStaticLib++    configDynExe              = toFlag elabDynExe+    configFullyStaticExe      = toFlag elabFullyStaticExe+    configGHCiLib             = toFlag elabGHCiLib+    configProfExe             = mempty+    configProfLib             = toFlag elabProfLib+    configProf                = toFlag elabProfExe++    -- configProfDetail is for exe+lib, but overridden by configProfLibDetail+    -- so we specify both so we can specify independently+    configProfDetail          = toFlag elabProfExeDetail+    configProfLibDetail       = toFlag elabProfLibDetail++    configCoverage            = toFlag elabCoverage+    configLibCoverage         = mempty++    configOptimization        = toFlag elabOptimization+    configSplitSections       = toFlag elabSplitSections+    configSplitObjs           = toFlag elabSplitObjs+    configStripExes           = toFlag elabStripExes+    configStripLibs           = toFlag elabStripLibs+    configDebugInfo           = toFlag elabDebugInfo++    configConfigurationsFlags = elabFlagAssignment+    configConfigureArgs       = elabConfigureScriptArgs+    configExtraLibDirs        = elabExtraLibDirs+    configExtraFrameworkDirs  = elabExtraFrameworkDirs+    configExtraIncludeDirs    = elabExtraIncludeDirs+    configProgPrefix          = maybe mempty toFlag elabProgPrefix+    configProgSuffix          = maybe mempty toFlag elabProgSuffix++    configInstallDirs         = fmap (toFlag . InstallDirs.toPathTemplate)+                                     elabInstallDirs++    -- we only use configDependencies, unless we're talking to an old Cabal+    -- in which case we use configConstraints+    -- NB: This does NOT use InstallPlan.depends, which includes executable+    -- dependencies which should NOT be fed in here (also you don't have+    -- enough info anyway)+    configDependencies        = [ GivenComponent+                                    (packageName srcid)+                                    ln+                                    cid+                                | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab+                                , let ln = case mb_cn+                                           of Just (CLibName lname) -> lname+                                              Just _ -> error "non-library dependency"+                                              Nothing -> LMainLibName+                                ]+    configConstraints         =+        case elabPkgOrComp of+            ElabPackage _ ->+                [ thisPackageVersionConstraint srcid+                | ConfiguredId srcid _ _uid <- elabLibDependencies elab ]+            ElabComponent _ -> []+++    -- explicitly clear, then our package db stack+    -- TODO: [required eventually] have to do this differently for older Cabal versions+    configPackageDBs          = Nothing : map Just elabBuildPackageDBStack++    configTests               = case elabPkgOrComp of+                                    ElabPackage pkg -> toFlag (TestStanzas  `optStanzaSetMember` pkgStanzasEnabled pkg)+                                    ElabComponent _ -> mempty+    configBenchmarks          = case elabPkgOrComp of+                                    ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)+                                    ElabComponent _ -> mempty++    configExactConfiguration  = toFlag True+    configFlagError           = mempty --TODO: [research required] appears not to be implemented+    configRelocatable         = mempty --TODO: [research required] ???+    configScratchDir          = mempty -- never use+    configUserInstall         = mempty -- don't rely on defaults+    configPrograms_           = mempty -- never use, shouldn't exist+    configUseResponseFiles    = mempty+    configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler++setupHsConfigureArgs :: ElaboratedConfiguredPackage+                     -> [String]+setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = []+setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) =+    [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)]+  where+    cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup")+                      (compComponentName comp)++setupHsBuildFlags :: ElaboratedConfiguredPackage+                  -> ElaboratedSharedConfig+                  -> Verbosity+                  -> FilePath+                  -> Cabal.BuildFlags+setupHsBuildFlags _ _ verbosity builddir =+    Cabal.BuildFlags {+      buildProgramPaths = mempty, --unused, set at configure time+      buildProgramArgs  = mempty, --unused, set at configure time+      buildVerbosity    = toFlag verbosity,+      buildDistPref     = toFlag builddir,+      buildNumJobs      = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),+      buildArgs         = mempty, -- unused, passed via args not flags+      buildCabalFilePath= mempty+    }+++setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]+setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ })+    -- Fix for #3335, don't pass build arguments if it's not supported+    | elabSetupScriptCliVersion elab >= mkVersion [1,17]+    = map (showComponentTarget (packageId elab)) (elabBuildTargets elab)+    | otherwise+    = []+setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ })+    = []+++setupHsTestFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.TestFlags+setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags+    { testDistPref    = toFlag builddir+    , testVerbosity   = toFlag verbosity+    , testMachineLog  = maybe mempty toFlag elabTestMachineLog+    , testHumanLog    = maybe mempty toFlag elabTestHumanLog+    , testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails+    , testKeepTix     = toFlag elabTestKeepTix+    , testWrapper     = maybe mempty toFlag elabTestWrapper+    , testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites+    , testOptions     = elabTestTestOptions+    }++setupHsTestArgs :: ElaboratedConfiguredPackage -> [String]+-- TODO: Does the issue #3335 affects test as well+setupHsTestArgs elab =+    mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab)+++setupHsBenchFlags :: ElaboratedConfiguredPackage+                  -> ElaboratedSharedConfig+                  -> Verbosity+                  -> FilePath+                  -> Cabal.BenchmarkFlags+setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags+    { benchmarkDistPref  = toFlag builddir+    , benchmarkVerbosity = toFlag verbosity+    , benchmarkOptions   = elabBenchmarkOptions+    }++setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String]+setupHsBenchArgs elab =+    mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab)+++setupHsReplFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.ReplFlags+setupHsReplFlags _ sharedConfig verbosity builddir =+    Cabal.ReplFlags {+      replProgramPaths = mempty, --unused, set at configure time+      replProgramArgs  = mempty, --unused, set at configure time+      replVerbosity    = toFlag verbosity,+      replDistPref     = toFlag builddir,+      replReload       = mempty, --only used as callback from repl+      replReplOptions  = pkgConfigReplOptions sharedConfig       --runtime override for repl flags+    }+++setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]+setupHsReplArgs elab =+    maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab)+    --TODO: should be able to give multiple modules in one component+++setupHsCopyFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> FilePath+                 -> Cabal.CopyFlags+setupHsCopyFlags _ _ verbosity builddir destdir =+    Cabal.CopyFlags {+      copyArgs      = [], -- TODO: could use this to only copy what we enabled+      copyDest      = toFlag (InstallDirs.CopyTo destdir),+      copyDistPref  = toFlag builddir,+      copyVerbosity = toFlag verbosity,+      copyCabalFilePath = mempty+    }++setupHsRegisterFlags :: ElaboratedConfiguredPackage+                     -> ElaboratedSharedConfig+                     -> Verbosity+                     -> FilePath+                     -> FilePath+                     -> Cabal.RegisterFlags+setupHsRegisterFlags ElaboratedConfiguredPackage{..} _+                     verbosity builddir pkgConfFile =+    Cabal.RegisterFlags {+      regPackageDB   = mempty,  -- misfeature+      regGenScript   = mempty,  -- never use+      regGenPkgConf  = toFlag (Just pkgConfFile),+      regInPlace     = case elabBuildStyle of+                         BuildInplaceOnly -> toFlag True+                         _                -> toFlag False,+      regPrintId     = mempty,  -- never use+      regDistPref    = toFlag builddir,+      regArgs        = [],+      regVerbosity   = toFlag verbosity,+      regCabalFilePath = mempty+    }++setupHsHaddockFlags :: ElaboratedConfiguredPackage+                    -> ElaboratedSharedConfig+                    -> Verbosity+                    -> FilePath+                    -> Cabal.HaddockFlags+setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir =+    Cabal.HaddockFlags {+      haddockProgramPaths  = mempty, --unused, set at configure time+      haddockProgramArgs   = mempty, --unused, set at configure time+      haddockHoogle        = toFlag elabHaddockHoogle,+      haddockHtml          = toFlag elabHaddockHtml,+      haddockHtmlLocation  = maybe mempty toFlag elabHaddockHtmlLocation,+      haddockForHackage    = toFlag elabHaddockForHackage,+      haddockForeignLibs   = toFlag elabHaddockForeignLibs,+      haddockExecutables   = toFlag elabHaddockExecutables,+      haddockTestSuites    = toFlag elabHaddockTestSuites,+      haddockBenchmarks    = toFlag elabHaddockBenchmarks,+      haddockInternal      = toFlag elabHaddockInternal,+      haddockCss           = maybe mempty toFlag elabHaddockCss,+      haddockLinkedSource  = toFlag elabHaddockLinkedSource,+      haddockQuickJump     = toFlag elabHaddockQuickJump,+      haddockHscolourCss   = maybe mempty toFlag elabHaddockHscolourCss,+      haddockContents      = maybe mempty toFlag elabHaddockContents,+      haddockDistPref      = toFlag builddir,+      haddockKeepTempFiles = mempty, --TODO: from build settings+      haddockVerbosity     = toFlag verbosity,+      haddockCabalFilePath = mempty,+      haddockArgs          = mempty+    }++setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String]+-- TODO: Does the issue #3335 affects test as well+setupHsHaddockArgs elab =+  map (showComponentTarget (packageId elab)) (elabHaddockTargets elab)++{-+setupHsTestFlags :: ElaboratedConfiguredPackage+                 -> ElaboratedSharedConfig+                 -> Verbosity+                 -> FilePath+                 -> Cabal.TestFlags+setupHsTestFlags _ _ verbosity builddir =+    Cabal.TestFlags {+    }+-}++------------------------------------------------------------------------------+-- * Sharing installed packages+------------------------------------------------------------------------------++--+-- Nix style store management for tarball packages+--+-- So here's our strategy:+--+-- We use a per-user nix-style hashed store, but /only/ for tarball packages.+-- So that includes packages from hackage repos (and other http and local+-- tarballs). For packages in local directories we do not register them into+-- the shared store by default, we just build them locally inplace.+--+-- The reason we do it like this is that it's easy to make stable hashes for+-- tarball packages, and these packages benefit most from sharing. By contrast+-- unpacked dir packages are harder to hash and they tend to change more+-- frequently so there's less benefit to sharing them.+--+-- When using the nix store approach we have to run the solver *without*+-- looking at the packages installed in the store, just at the source packages+-- (plus core\/global installed packages). Then we do a post-processing pass+-- to replace configured packages in the plan with pre-existing ones, where+-- possible. Where possible of course means where the nix-style package hash+-- equals one that's already in the store.+--+-- One extra wrinkle is that unless we know package tarball hashes upfront, we+-- will have to download the tarballs to find their hashes. So we have two+-- options: delay replacing source with pre-existing installed packages until+-- the point during the execution of the install plan where we have the+-- tarball, or try to do as much up-front as possible and then check again+-- during plan execution. The former isn't great because we would end up+-- telling users we're going to re-install loads of packages when in fact we+-- would just share them. It'd be better to give as accurate a prediction as+-- we can. The latter is better for users, but we do still have to check+-- during plan execution because it's important that we don't replace existing+-- installed packages even if they have the same package hash, because we+-- don't guarantee ABI stability.++-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but+-- not replace installed packages with ghc-pkg.++packageHashInputs :: ElaboratedSharedConfig+                  -> ElaboratedConfiguredPackage+                  -> PackageHashInputs+packageHashInputs+    pkgshared+    elab@(ElaboratedConfiguredPackage {+      elabPkgSourceHash = Just srchash+    }) =+    PackageHashInputs {+      pkgHashPkgId       = packageId elab,+      pkgHashComponent   =+        case elabPkgOrComp elab of+          ElabPackage _ -> Nothing+          ElabComponent comp -> Just (compSolverName comp),+      pkgHashSourceHash  = srchash,+      pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab),+      pkgHashDirectDeps  =+        case elabPkgOrComp elab of+          ElabPackage (ElaboratedPackage{..}) ->+            Set.fromList $+             [ confInstId dep+             | dep <- CD.select relevantDeps pkgLibDependencies ] +++             [ confInstId dep+             | dep <- CD.select relevantDeps pkgExeDependencies ]+          ElabComponent comp ->+            Set.fromList (map confInstId (compLibDependencies comp+                                       ++ compExeDependencies comp)),+      pkgHashOtherConfig = packageHashConfigInputs pkgshared elab+    }+  where+    -- Obviously the main deps are relevant+    relevantDeps CD.ComponentLib       = True+    relevantDeps (CD.ComponentSubLib _) = True+    relevantDeps (CD.ComponentFLib _)   = True+    relevantDeps (CD.ComponentExe _)   = True+    -- Setup deps can affect the Setup.hs behaviour and thus what is built+    relevantDeps  CD.ComponentSetup    = True+    -- However testsuites and benchmarks do not get installed and should not+    -- affect the result, so we do not include them.+    relevantDeps (CD.ComponentTest  _) = False+    relevantDeps (CD.ComponentBench _) = False++packageHashInputs _ pkg =+    error $ "packageHashInputs: only for packages with source hashes. "+         ++ prettyShow (packageId pkg)++packageHashConfigInputs :: ElaboratedSharedConfig+                        -> ElaboratedConfiguredPackage+                        -> PackageHashConfigInputs+packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =+    PackageHashConfigInputs {+      pkgHashCompilerId          = compilerId pkgConfigCompiler,+      pkgHashPlatform            = pkgConfigPlatform,+      pkgHashFlagAssignment      = elabFlagAssignment,+      pkgHashConfigureScriptArgs = elabConfigureScriptArgs,+      pkgHashVanillaLib          = elabVanillaLib,+      pkgHashSharedLib           = elabSharedLib,+      pkgHashDynExe              = elabDynExe,+      pkgHashFullyStaticExe      = elabFullyStaticExe,+      pkgHashGHCiLib             = elabGHCiLib,+      pkgHashProfLib             = elabProfLib,+      pkgHashProfExe             = elabProfExe,+      pkgHashProfLibDetail       = elabProfLibDetail,+      pkgHashProfExeDetail       = elabProfExeDetail,+      pkgHashCoverage            = elabCoverage,+      pkgHashOptimization        = elabOptimization,+      pkgHashSplitSections       = elabSplitSections,+      pkgHashSplitObjs           = elabSplitObjs,+      pkgHashStripLibs           = elabStripLibs,+      pkgHashStripExes           = elabStripExes,+      pkgHashDebugInfo           = elabDebugInfo,+      pkgHashProgramArgs         = elabProgramArgs,+      pkgHashExtraLibDirs        = elabExtraLibDirs,+      pkgHashExtraFrameworkDirs  = elabExtraFrameworkDirs,+      pkgHashExtraIncludeDirs    = elabExtraIncludeDirs,+      pkgHashProgPrefix          = elabProgPrefix,+      pkgHashProgSuffix          = elabProgSuffix,++      pkgHashDocumentation       = elabBuildHaddocks,+      pkgHashHaddockHoogle       = elabHaddockHoogle,+      pkgHashHaddockHtml         = elabHaddockHtml,+      pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation,+      pkgHashHaddockForeignLibs  = elabHaddockForeignLibs,+      pkgHashHaddockExecutables  = elabHaddockExecutables,+      pkgHashHaddockTestSuites   = elabHaddockTestSuites,+      pkgHashHaddockBenchmarks   = elabHaddockBenchmarks,+      pkgHashHaddockInternal     = elabHaddockInternal,+      pkgHashHaddockCss          = elabHaddockCss,+      pkgHashHaddockLinkedSource = elabHaddockLinkedSource,+      pkgHashHaddockQuickJump    = elabHaddockQuickJump,+      pkgHashHaddockContents     = elabHaddockContents+    }+  where+    ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg++-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an+-- 'ElaboratedInstallPlan', replace configured source packages by installed+-- packages from the store whenever they exist.+--+improveInstallPlanWithInstalledPackages :: Set UnitId+                                        -> ElaboratedInstallPlan+                                        -> ElaboratedInstallPlan+improveInstallPlanWithInstalledPackages installedPkgIdSet =+    InstallPlan.installed canPackageBeImproved+  where+    canPackageBeImproved pkg =+      installedUnitId pkg `Set.member` installedPkgIdSet+    --TODO: sanity checks:+    -- * the installed package must have the expected deps etc+    -- * the installed package must not be broken, valid dep closure++    --TODO: decide what to do if we encounter broken installed packages,+    -- since overwriting is never safe.+++-- Path construction+------++-- | The path to the directory that contains a specific executable.+-- NB: For inplace NOT InstallPaths.bindir installDirs; for an+-- inplace build those values are utter nonsense.  So we+-- have to guess where the directory is going to be.+-- Fortunately this is "stable" part of Cabal API.+-- But the way we get the build directory is A HORRIBLE+-- HACK.+binDirectoryFor+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedConfiguredPackage+  -> FilePath+  -> FilePath+binDirectoryFor layout config package exe = case elabBuildStyle package of+  BuildAndInstall -> installedBinDirectory package+  BuildInplaceOnly -> inplaceBinRoot layout config package </> exe++-- package has been built and installed.+installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath+installedBinDirectory = InstallDirs.bindir . elabInstallDirs++-- | The path to the @build@ directory for an inplace build.+inplaceBinRoot+  :: DistDirLayout+  -> ElaboratedSharedConfig+  -> ElaboratedConfiguredPackage+  -> FilePath+inplaceBinRoot layout config package+  =  distBuildDirectory layout (elabDistDirParams config package)+ </> "build"
+ src/Distribution/Client/ProjectPlanning/Types.hs view
@@ -0,0 +1,851 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}++-- | Types used while planning how to build everything in a project.+--+-- Primarily this is the 'ElaboratedInstallPlan'.+--+module Distribution.Client.ProjectPlanning.Types (+    SolverInstallPlan,++    -- * Elaborated install plan types+    ElaboratedInstallPlan,+    normaliseConfiguredPackage,+    ElaboratedConfiguredPackage(..),++    elabDistDirParams,+    elabExeDependencyPaths,+    elabLibDependencies,+    elabOrderLibDependencies,+    elabExeDependencies,+    elabOrderExeDependencies,+    elabSetupDependencies,+    elabPkgConfigDependencies,+    elabInplaceDependencyBuildCacheFiles,+    elabRequiresRegistration,+    dataDirsEnvironmentForPlan,++    elabPlanPackageName,+    elabConfiguredName,+    elabComponentName,++    ElaboratedPackageOrComponent(..),+    ElaboratedComponent(..),+    ElaboratedPackage(..),+    pkgOrderDependencies,+    ElaboratedPlanPackage,+    ElaboratedSharedConfig(..),+    ElaboratedReadyPackage,+    BuildStyle(..),+    CabalFileText,++    -- * Build targets+    ComponentTarget(..),+    showComponentTarget,+    showTestComponentTarget,+    showBenchComponentTarget,+    SubComponentTarget(..),++    isSubLibComponentTarget,+    isForeignLibComponentTarget,+    isExeComponentTarget,+    isTestComponentTarget,+    isBenchComponentTarget,++    componentOptionalStanza,++    -- * Setup script+    SetupScriptStyle(..),+  ) where++import           Distribution.Client.Compat.Prelude+import           Prelude ()++import           Distribution.Client.TargetSelector+                   ( SubComponentTarget(..) )+import           Distribution.Client.PackageHash++import           Distribution.Client.Types+import qualified Distribution.Client.InstallPlan as InstallPlan+import           Distribution.Client.InstallPlan+                   ( GenericInstallPlan, GenericPlanPackage(..) )+import           Distribution.Client.SolverInstallPlan+                   ( SolverInstallPlan )+import           Distribution.Client.DistDirLayout++import           Distribution.Backpack+import           Distribution.Backpack.ModuleShape++import           Distribution.Verbosity (normal)+import           Distribution.Types.ComponentRequestedSpec+import           Distribution.Types.PkgconfigVersion+import           Distribution.Types.PackageDescription (PackageDescription(..))+import           Distribution.Package+import           Distribution.System+import qualified Distribution.PackageDescription as Cabal+import           Distribution.InstalledPackageInfo (InstalledPackageInfo)+import           Distribution.Simple.Compiler+import           Distribution.Simple.Build.PathsModule (pkgPathEnvVar)+import qualified Distribution.Simple.BuildTarget as Cabal+import           Distribution.Simple.Program+import           Distribution.ModuleName (ModuleName)+import           Distribution.Simple.LocalBuildInfo+                   ( ComponentName(..), LibraryName(..) )+import qualified Distribution.Simple.InstallDirs as InstallDirs+import           Distribution.Simple.InstallDirs (PathTemplate)+import           Distribution.Simple.Setup (HaddockTarget, TestShowDetails)+import           Distribution.Version++import qualified Distribution.Solver.Types.ComponentDeps as CD+import           Distribution.Solver.Types.ComponentDeps (ComponentDeps)+import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Compat.Graph (IsNode(..))+import           Distribution.Simple.Utils (ordNub)++import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Monoid as Mon+import           System.FilePath ((</>))+++-- | The combination of an elaborated install plan plus a+-- 'ElaboratedSharedConfig' contains all the details necessary to be able+-- to execute the plan without having to make further policy decisions.+--+-- It does not include dynamic elements such as resources (such as http+-- connections).+--+type ElaboratedInstallPlan+   = GenericInstallPlan InstalledPackageInfo+                        ElaboratedConfiguredPackage++type ElaboratedPlanPackage+   = GenericPlanPackage InstalledPackageInfo+                        ElaboratedConfiguredPackage++-- | User-friendly display string for an 'ElaboratedPlanPackage'.+elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String+elabPlanPackageName verbosity (PreExisting ipkg)+    | verbosity <= normal = prettyShow (packageName ipkg)+    | otherwise           = prettyShow (installedUnitId ipkg)+elabPlanPackageName verbosity (Configured elab)+    = elabConfiguredName verbosity elab+elabPlanPackageName verbosity (Installed elab)+    = elabConfiguredName verbosity elab++--TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle+--      even platform and compiler could be different if we're building things+--      like a server + client with ghc + ghcjs+data ElaboratedSharedConfig+   = ElaboratedSharedConfig {++       pkgConfigPlatform      :: Platform,+       pkgConfigCompiler      :: Compiler, --TODO: [code cleanup] replace with CompilerInfo+       -- | The programs that the compiler configured (e.g. for GHC, the progs+       -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are+       -- used.+       pkgConfigCompilerProgs :: ProgramDb,+       pkgConfigReplOptions :: [String]+     }+  deriving (Show, Generic, Typeable)+  --TODO: [code cleanup] no Eq instance++instance Binary ElaboratedSharedConfig+instance Structured ElaboratedSharedConfig++data ElaboratedConfiguredPackage+   = ElaboratedConfiguredPackage {+       -- | The 'UnitId' which uniquely identifies this item in a build plan+       elabUnitId        :: UnitId,++       elabComponentId :: ComponentId,+       elabInstantiatedWith :: Map ModuleName Module,+       elabLinkedInstantiatedWith :: Map ModuleName OpenModule,++       -- | This is true if this is an indefinite package, or this is a+       -- package with no signatures.  (Notably, it's not true for instantiated+       -- packages.)  The motivation for this is if you ask to build+       -- @foo-indef@, this probably means that you want to typecheck+       -- it, NOT that you want to rebuild all of the various+       -- instantiations of it.+       elabIsCanonical :: Bool,++       -- | The 'PackageId' of the originating package+       elabPkgSourceId    :: PackageId,++       -- | Shape of the package/component, for Backpack.+       elabModuleShape    :: ModuleShape,++       -- | A total flag assignment for the package.+       -- TODO: Actually this can be per-component if we drop+       -- all flags that don't affect a component.+       elabFlagAssignment   :: Cabal.FlagAssignment,++       -- | The original default flag assignment, used only for reporting.+       elabFlagDefaults     :: Cabal.FlagAssignment,++       elabPkgDescription :: Cabal.PackageDescription,++       -- | Where the package comes from, e.g. tarball, local dir etc. This+       --   is not the same as where it may be unpacked to for the build.+       elabPkgSourceLocation :: PackageLocation (Maybe FilePath),++       -- | The hash of the source, e.g. the tarball. We don't have this for+       -- local source dir packages.+       elabPkgSourceHash     :: Maybe PackageSourceHash,++       -- | Is this package one of the ones specified by location in the+       -- project file? (As opposed to a dependency, or a named package pulled+       -- in)+       elabLocalToProject         :: Bool,++       -- | Are we going to build and install this package to the store, or are+       -- we going to build it and register it locally.+       elabBuildStyle             :: BuildStyle,++       -- | Another way of phrasing 'pkgStanzasAvailable'.+       elabEnabledSpec      :: ComponentRequestedSpec,++       -- | Which optional stanzas (ie testsuites, benchmarks) can be built.+       -- This means the solver produced a plan that has them available.+       -- This doesn't necessary mean we build them by default.+       elabStanzasAvailable :: OptionalStanzaSet,++       -- | Which optional stanzas the user explicitly asked to enable or+       -- to disable. This tells us which ones we build by default, and+       -- helps with error messages when the user asks to build something+       -- they explicitly disabled.+       --+       -- TODO: The 'Bool' here should be refined into an ADT with three+       -- cases: NotRequested, ExplicitlyRequested and+       -- ImplicitlyRequested.  A stanza is explicitly requested if+       -- the user asked, for this *specific* package, that the stanza+       -- be enabled; it's implicitly requested if the user asked for+       -- all global packages to have this stanza enabled.  The+       -- difference between an explicit and implicit request is+       -- error reporting behavior: if a user asks for tests to be+       -- enabled for a specific package that doesn't have any tests,+       -- we should warn them about it, but we shouldn't complain+       -- that a user enabled tests globally, and some local packages+       -- just happen not to have any tests.  (But perhaps we should+       -- warn if ALL local packages don't have any tests.)+       elabStanzasRequested :: OptionalStanzaMap (Maybe Bool),++       elabSetupPackageDBStack    :: PackageDBStack,+       elabBuildPackageDBStack    :: PackageDBStack,+       elabRegisterPackageDBStack :: PackageDBStack,++       elabInplaceSetupPackageDBStack    :: PackageDBStack,+       elabInplaceBuildPackageDBStack    :: PackageDBStack,+       elabInplaceRegisterPackageDBStack :: PackageDBStack,++       elabPkgDescriptionOverride  :: Maybe CabalFileText,++       -- TODO: make per-component variants of these flags+       elabVanillaLib           :: Bool,+       elabSharedLib            :: Bool,+       elabStaticLib            :: Bool,+       elabDynExe               :: Bool,+       elabFullyStaticExe       :: Bool,+       elabGHCiLib              :: Bool,+       elabProfLib              :: Bool,+       elabProfExe              :: Bool,+       elabProfLibDetail        :: ProfDetailLevel,+       elabProfExeDetail        :: ProfDetailLevel,+       elabCoverage             :: Bool,+       elabOptimization         :: OptimisationLevel,+       elabSplitObjs            :: Bool,+       elabSplitSections        :: Bool,+       elabStripLibs            :: Bool,+       elabStripExes            :: Bool,+       elabDebugInfo            :: DebugInfoLevel,++       elabProgramPaths          :: Map String FilePath,+       elabProgramArgs           :: Map String [String],+       elabProgramPathExtra      :: [FilePath],+       elabConfigureScriptArgs   :: [String],+       elabExtraLibDirs          :: [FilePath],+       elabExtraFrameworkDirs    :: [FilePath],+       elabExtraIncludeDirs      :: [FilePath],+       elabProgPrefix            :: Maybe PathTemplate,+       elabProgSuffix            :: Maybe PathTemplate,++       elabInstallDirs           :: InstallDirs.InstallDirs FilePath,++       elabHaddockHoogle         :: Bool,+       elabHaddockHtml           :: Bool,+       elabHaddockHtmlLocation   :: Maybe String,+       elabHaddockForeignLibs    :: Bool,+       elabHaddockForHackage     :: HaddockTarget,+       elabHaddockExecutables    :: Bool,+       elabHaddockTestSuites     :: Bool,+       elabHaddockBenchmarks     :: Bool,+       elabHaddockInternal       :: Bool,+       elabHaddockCss            :: Maybe FilePath,+       elabHaddockLinkedSource   :: Bool,+       elabHaddockQuickJump      :: Bool,+       elabHaddockHscolourCss    :: Maybe FilePath,+       elabHaddockContents       :: Maybe PathTemplate,++       elabTestMachineLog        :: Maybe PathTemplate,+       elabTestHumanLog          :: Maybe PathTemplate,+       elabTestShowDetails       :: Maybe TestShowDetails,+       elabTestKeepTix           :: Bool,+       elabTestWrapper           :: Maybe FilePath,+       elabTestFailWhenNoTestSuites :: Bool,+       elabTestTestOptions       :: [PathTemplate],++       elabBenchmarkOptions      :: [PathTemplate],++       -- Setup.hs related things:++       -- | One of four modes for how we build and interact with the Setup.hs+       -- script, based on whether it's a build-type Custom, with or without+       -- explicit deps and the cabal spec version the .cabal file needs.+       elabSetupScriptStyle      :: SetupScriptStyle,++       -- | The version of the Cabal command line interface that we are using+       -- for this package. This is typically the version of the Cabal lib+       -- that the Setup.hs is built against.+       --+       -- TODO: We might want to turn this into a enum,+       -- yet different enum than 'CabalSpecVersion'.+       elabSetupScriptCliVersion :: Version,++       -- Build time related:+       elabConfigureTargets      :: [ComponentTarget],+       elabBuildTargets          :: [ComponentTarget],+       elabTestTargets           :: [ComponentTarget],+       elabBenchTargets          :: [ComponentTarget],+       elabReplTarget            :: Maybe ComponentTarget,+       elabHaddockTargets        :: [ComponentTarget],++       elabBuildHaddocks         :: Bool,++       --pkgSourceDir ? -- currently passed in later because they can use temp locations+       --pkgBuildDir  ? -- but could in principle still have it here, with optional instr to use temp loc++       -- | Component/package specific information+       elabPkgOrComp :: ElaboratedPackageOrComponent+   }+  deriving (Eq, Show, Generic, Typeable)++normaliseConfiguredPackage :: ElaboratedSharedConfig+                           -> ElaboratedConfiguredPackage+                           -> ElaboratedConfiguredPackage+normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =+    pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) }+  where+    knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs++    pkgDesc :: PackageDescription+    pkgDesc = elabPkgDescription pkg++    removeEmpty :: [String] -> Maybe [String]+    removeEmpty [] = Nothing+    removeEmpty xs = Just xs++    lookupFilter :: String -> [String] -> Maybe [String]+    lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of+        Just p -> programNormaliseArgs p (getVersion p) pkgDesc args+        Nothing -> args++    getVersion :: Program -> Maybe Version+    getVersion p = lookupProgram p knownProgramDb >>= programVersion++-- | The package/component contains/is a library and so must be registered+elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool+elabRequiresRegistration elab =+    case elabPkgOrComp elab of+        ElabComponent comp ->+            case compComponentName comp of+                Just cn -> is_lib cn && build_target+                _ -> False+        ElabPackage pkg ->+            -- Tricky! Not only do we have to test if the user selected+            -- a library as a build target, we also have to test if+            -- the library was TRANSITIVELY depended upon, since we will+            -- also require a register in this case.+            --+            -- NB: It would have been far nicer to just unconditionally+            -- register in all cases, but some Custom Setups will fall+            -- over if you try to do that, ESPECIALLY if there actually is+            -- a library but they hadn't built it.+            --+            -- However, as the case of `cpphs-1.20.8` has shown in+            -- #5379, in cases when a monolithic package gets+            -- installed due to its executable components+            -- (i.e. exe:cpphs) into the store we *have* to register+            -- if there's a buildable public library (i.e. lib:cpphs)+            -- that was built and installed into the same store folder+            -- as otherwise this will cause build failures once a+            -- target actually depends on lib:cpphs.+            build_target || (elabBuildStyle elab == BuildAndInstall &&+                             Cabal.hasPublicLib (elabPkgDescription elab))+            -- the next sub-condition below is currently redundant+            -- (see discussion in #5604 for more details), but it's+            -- being kept intentionally here as a safeguard because if+            -- internal libraries ever start working with+            -- non-per-component builds this condition won't be+            -- redundant anymore.+                         || any (depends_on_lib pkg) (elabBuildTargets elab)+  where+    depends_on_lib pkg (ComponentTarget cn _) =+        not (null (CD.select (== CD.componentNameToComponent cn)+                             (pkgDependsOnSelfLib pkg)))+    build_target =+        if not (null (elabBuildTargets elab))+            then any is_lib_target (elabBuildTargets elab)+            -- Empty build targets mean we build /everything/;+            -- that means we have to look more carefully to see+            -- if there is anything to register+            else Cabal.hasLibs (elabPkgDescription elab)+    -- NB: this means we DO NOT reregister if you just built a+    -- single file+    is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn+    is_lib_target _ = False+    is_lib (CLibName _) = True+    is_lib _ = False++-- | Construct the environment needed for the data files to work.+-- This consists of a separate @*_datadir@ variable for each+-- inplace package in the plan.+dataDirsEnvironmentForPlan :: DistDirLayout+                           -> ElaboratedInstallPlan+                           -> [(String, Maybe FilePath)]+dataDirsEnvironmentForPlan distDirLayout = catMaybes+                           . fmap (InstallPlan.foldPlanPackage+                               (const Nothing)+                               (dataDirEnvVarForPackage distDirLayout))+                           . InstallPlan.toList++-- | Construct an environment variable that points+-- the package's datadir to its correct location.+-- This might be:+-- * 'Just' the package's source directory plus the data subdirectory+--   for inplace packages.+-- * 'Nothing' for packages installed in the store (the path was+--   already included in the package at install/build time).+dataDirEnvVarForPackage :: DistDirLayout+                        -> ElaboratedConfiguredPackage+                        -> Maybe (String, Maybe FilePath)+dataDirEnvVarForPackage distDirLayout pkg =+  case elabBuildStyle pkg+  of BuildAndInstall -> Nothing+     BuildInplaceOnly -> Just+       ( pkgPathEnvVar (elabPkgDescription pkg) "datadir"+       , Just $ srcPath (elabPkgSourceLocation pkg)+            </> dataDir (elabPkgDescription pkg))+  where+    srcPath (LocalUnpackedPackage path) = path+    srcPath (LocalTarballPackage _path) = unpackedPath+    srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath+    srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath+    srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout+    -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc+    srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error+      "calling dataDirEnvVarForPackage on a not-downloaded repo is an error"+    unpackedPath =+      distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg++instance Package ElaboratedConfiguredPackage where+  packageId = elabPkgSourceId++instance HasConfiguredId ElaboratedConfiguredPackage where+  configuredId elab =+    ConfiguredId (packageId elab) (elabComponentName elab) (elabComponentId elab)++instance HasUnitId ElaboratedConfiguredPackage where+  installedUnitId = elabUnitId++instance IsNode ElaboratedConfiguredPackage where+    type Key ElaboratedConfiguredPackage = UnitId+    nodeKey = elabUnitId+    nodeNeighbors = elabOrderDependencies++instance Binary ElaboratedConfiguredPackage+instance Structured ElaboratedConfiguredPackage++data ElaboratedPackageOrComponent+    = ElabPackage   ElaboratedPackage+    | ElabComponent ElaboratedComponent+  deriving (Eq, Show, Generic)++instance Binary ElaboratedPackageOrComponent+instance Structured ElaboratedPackageOrComponent++elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName+elabComponentName elab =+    case elabPkgOrComp elab of+        ElabPackage _      -> Just $ CLibName LMainLibName -- there could be more, but default this+        ElabComponent comp -> compComponentName comp++-- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'.+elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String+elabConfiguredName verbosity elab+    | verbosity <= normal+    = (case elabPkgOrComp elab of+        ElabPackage _ -> ""+        ElabComponent comp ->+            case compComponentName comp of+                Nothing -> "setup from "+                Just (CLibName LMainLibName) -> ""+                Just cname -> prettyShow cname ++ " from ")+      ++ prettyShow (packageId elab)+    | otherwise+    = prettyShow (elabUnitId elab)++elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams+elabDistDirParams shared elab = DistDirParams {+        distParamUnitId = installedUnitId elab,+        distParamComponentId = elabComponentId elab,+        distParamPackageId = elabPkgSourceId elab,+        distParamComponentName = case elabPkgOrComp elab of+            ElabComponent comp -> compComponentName comp+            ElabPackage _ -> Nothing,+        distParamCompilerId = compilerId (pkgConfigCompiler shared),+        distParamPlatform = pkgConfigPlatform shared,+        distParamOptimization = elabOptimization elab+    }++-- | The full set of dependencies which dictate what order we+-- need to build things in the install plan: "order dependencies"+-- balls everything together.  This is mostly only useful for+-- ordering; if you are, for example, trying to compute what+-- @--dependency@ flags to pass to a Setup script, you need to+-- use 'elabLibDependencies'.  This method is the same as+-- 'nodeNeighbors'.+--+-- NB: this method DOES include setup deps.+elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId]+elabOrderDependencies elab =+    case elabPkgOrComp elab of+        -- Important not to have duplicates: otherwise InstallPlan gets+        -- confused.+        ElabPackage pkg    -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))+        ElabComponent comp -> compOrderDependencies comp++-- | Like 'elabOrderDependencies', but only returns dependencies on+-- libraries.+elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId]+elabOrderLibDependencies elab =+    case elabPkgOrComp elab of+        ElabPackage pkg    -> map (newSimpleUnitId . confInstId) $+                              ordNub $ CD.flatDeps (pkgLibDependencies pkg)+        ElabComponent comp -> compOrderLibDependencies comp++-- | The library dependencies (i.e., the libraries we depend on, NOT+-- the dependencies of the library), NOT including setup dependencies.+-- These are passed to the @Setup@ script via @--dependency@.+elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]+elabLibDependencies elab =+    case elabPkgOrComp elab of+        ElabPackage pkg    -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg))+        ElabComponent comp -> compLibDependencies comp++-- | Like 'elabOrderDependencies', but only returns dependencies on+-- executables.  (This coincides with 'elabExeDependencies'.)+elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId]+elabOrderExeDependencies =+    map newSimpleUnitId . elabExeDependencies++-- | The executable dependencies (i.e., the executables we depend on);+-- these are the executables we must add to the PATH before we invoke+-- the setup script.+elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId]+elabExeDependencies elab = map confInstId $+    case elabPkgOrComp elab of+        ElabPackage pkg    -> CD.nonSetupDeps (pkgExeDependencies pkg)+        ElabComponent comp -> compExeDependencies comp++-- | This returns the paths of all the executables we depend on; we+-- must add these paths to PATH before invoking the setup script.+-- (This is usually what you want, not 'elabExeDependencies', if you+-- actually want to build something.)+elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath]+elabExeDependencyPaths elab =+    case elabPkgOrComp elab of+        ElabPackage pkg    -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg)+        ElabComponent comp -> map snd (compExeDependencyPaths comp)++-- | The setup dependencies (the library dependencies of the setup executable;+-- note that it is not legal for setup scripts to have executable+-- dependencies at the moment.)+elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]+elabSetupDependencies elab =+    case elabPkgOrComp elab of+        ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg)+        -- TODO: Custom setups not supported for components yet.  When+        -- they are, need to do this differently+        ElabComponent _ -> []++elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)]+elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg }+    = pkgPkgConfigDependencies pkg+elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }+    = compPkgConfigDependencies comp++-- | The cache files of all our inplace dependencies which,+-- when updated, require us to rebuild.  See #4202 for+-- more details.  Essentially, this is a list of filepaths+-- that, if our dependencies get rebuilt, will themselves+-- get updated.+--+-- Note: the hash of these cache files gets built into+-- the build cache ourselves, which means that we end+-- up tracking transitive dependencies!+--+-- Note: This tracks the "build" cache file, but not+-- "registration" or "config" cache files.  Why not?+-- Arguably we should...+--+-- Note: This is a bit of a hack, because it is not really+-- the hashes of the SOURCES of our (transitive) dependencies+-- that we should use to decide whether or not to rebuild,+-- but the output BUILD PRODUCTS.  The strategy we use+-- here will never work if we want to implement unchanging+-- rebuilds.+elabInplaceDependencyBuildCacheFiles+    :: DistDirLayout+    -> ElaboratedSharedConfig+    -> ElaboratedInstallPlan+    -> ElaboratedConfiguredPackage+    -> [FilePath]+elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab =+    go =<< InstallPlan.directDeps plan (nodeKey root_elab)+  where+    go = InstallPlan.foldPlanPackage (const []) $ \elab -> do+            guard (elabBuildStyle elab == BuildInplaceOnly)+            return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build"++-- | Some extra metadata associated with an+-- 'ElaboratedConfiguredPackage' which indicates that the "package"+-- in question is actually a single component to be built.  Arguably+-- it would be clearer if there were an ADT which branched into+-- package work items and component work items, but I've structured+-- it this way to minimize change to the existing code (which I+-- don't feel qualified to rewrite.)+data ElaboratedComponent+   = ElaboratedComponent {+    -- | The name of the component to be built according to the solver+    compSolverName :: CD.Component,+    -- | The name of the component to be built.  Nothing if+    -- it's a setup dep.+    compComponentName :: Maybe ComponentName,+    -- | The *external* library dependencies of this component.  We+    -- pass this to the configure script.+    compLibDependencies :: [ConfiguredId],+    -- | In a component prior to instantiation, this list specifies+    -- the 'OpenUnitId's which, after instantiation, are the+    -- actual dependencies of this package.  Note that this does+    -- NOT include signature packages, which do not turn into real+    -- ordering dependencies when we instantiate.  This is intended to be+    -- a purely temporary field, to carry some information to the+    -- instantiation phase. It's more precise than+    -- 'compLibDependencies', and also stores information about internal+    -- dependencies.+    compLinkedLibDependencies :: [OpenUnitId],+    -- | The executable dependencies of this component (including+    -- internal executables).+    compExeDependencies :: [ConfiguredId],+    -- | The @pkg-config@ dependencies of the component+    compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)],+    -- | The paths all our executable dependencies will be installed+    -- to once they are installed.+    compExeDependencyPaths :: [(ConfiguredId, FilePath)],+    -- | The UnitIds of the libraries (identifying elaborated packages/+    -- components) that must be built before this project.  This+    -- is used purely for ordering purposes.  It can contain both+    -- references to definite and indefinite packages; an indefinite+    -- UnitId indicates that we must typecheck that indefinite package+    -- before we can build this one.+    compOrderLibDependencies :: [UnitId]+   }+  deriving (Eq, Show, Generic)++instance Binary ElaboratedComponent+instance Structured ElaboratedComponent++-- | See 'elabOrderDependencies'.+compOrderDependencies :: ElaboratedComponent -> [UnitId]+compOrderDependencies comp =+    compOrderLibDependencies comp+ ++ compOrderExeDependencies comp++-- | See 'elabOrderExeDependencies'.+compOrderExeDependencies :: ElaboratedComponent -> [UnitId]+compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies++data ElaboratedPackage+   = ElaboratedPackage {+       pkgInstalledId :: InstalledPackageId,++       -- | The exact dependencies (on other plan packages)+       --+       pkgLibDependencies :: ComponentDeps [ConfiguredId],++       -- | Components which depend (transitively) on an internally+       -- defined library.  These are used by 'elabRequiresRegistration',+       -- to determine if a user-requested build is going to need+       -- a library registration+       --+       pkgDependsOnSelfLib :: ComponentDeps [()],++       -- | Dependencies on executable packages.+       --+       pkgExeDependencies :: ComponentDeps [ConfiguredId],++       -- | Paths where executable dependencies live.+       --+       pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)],++       -- | Dependencies on @pkg-config@ packages.+       -- NB: this is NOT per-component (although it could be)+       -- because Cabal library does not track per-component+       -- pkg-config depends; it always does them all at once.+       --+       pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)],++       -- | Which optional stanzas (ie testsuites, benchmarks) will actually+       -- be enabled during the package configure step.+       pkgStanzasEnabled :: OptionalStanzaSet+     }+  deriving (Eq, Show, Generic)++instance Binary ElaboratedPackage+instance Structured ElaboratedPackage++-- | See 'elabOrderDependencies'.  This gives the unflattened version,+-- which can be useful in some circumstances.+pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId]+pkgOrderDependencies pkg =+    fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend`+    fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg)++-- | This is used in the install plan to indicate how the package will be+-- built.+--+data BuildStyle =+    -- | The classic approach where the package is built, then the files+    -- installed into some location and the result registered in a package db.+    --+    -- If the package came from a tarball then it's built in a temp dir and+    -- the results discarded.+    BuildAndInstall++    -- | The package is built, but the files are not installed anywhere,+    -- rather the build dir is kept and the package is registered inplace.+    --+    -- Such packages can still subsequently be installed.+    --+    -- Typically 'BuildAndInstall' packages will only depend on other+    -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.+    --+  | BuildInplaceOnly+  deriving (Eq, Show, Generic)++instance Binary BuildStyle+instance Structured BuildStyle+instance Semigroup BuildStyle where+    BuildInplaceOnly <> _ = BuildInplaceOnly+    _ <> BuildInplaceOnly = BuildInplaceOnly+    _ <> _ = BuildAndInstall+instance Monoid BuildStyle where+    mempty = BuildAndInstall+    mappend = (<>)++type CabalFileText = LBS.ByteString++type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage+++---------------------------+-- Build targets+--++-- | Specific targets within a package or component to act on e.g. to build,+-- haddock or open a repl.+--+data ComponentTarget = ComponentTarget ComponentName SubComponentTarget+  deriving (Eq, Ord, Show, Generic)++instance Binary ComponentTarget+instance Structured ComponentTarget++-- | Unambiguously render a 'ComponentTarget', e.g., to pass+-- to a Cabal Setup script.+showComponentTarget :: PackageId -> ComponentTarget -> String+showComponentTarget pkgid =+    Cabal.showBuildTarget pkgid . toBuildTarget+  where+    toBuildTarget :: ComponentTarget -> Cabal.BuildTarget+    toBuildTarget (ComponentTarget cname subtarget) =+      case subtarget of+        WholeComponent     -> Cabal.BuildTargetComponent cname+        ModuleTarget mname -> Cabal.BuildTargetModule    cname mname+        FileTarget   fname -> Cabal.BuildTargetFile      cname fname++showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String+showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n+showTestComponentTarget _ _ = Nothing++isTestComponentTarget :: ComponentTarget -> Bool+isTestComponentTarget (ComponentTarget (CTestName _) _) = True+isTestComponentTarget _                                 = False++showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String+showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n+showBenchComponentTarget _ _ = Nothing++isBenchComponentTarget :: ComponentTarget -> Bool+isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True+isBenchComponentTarget _                                  = False++isForeignLibComponentTarget :: ComponentTarget -> Bool+isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True+isForeignLibComponentTarget _                                 = False++isExeComponentTarget :: ComponentTarget -> Bool+isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True+isExeComponentTarget _                                 = False++isSubLibComponentTarget :: ComponentTarget -> Bool+isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True+isSubLibComponentTarget _                                              = False++componentOptionalStanza :: CD.Component -> Maybe OptionalStanza+componentOptionalStanza (CD.ComponentTest _)  = Just TestStanzas+componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas+componentOptionalStanza _                     = Nothing++---------------------------+-- Setup.hs script policy+--++-- | There are four major cases for Setup.hs handling:+--+--  1. @build-type@ Custom with a @custom-setup@ section+--  2. @build-type@ Custom without a @custom-setup@ section+--  3. @build-type@ not Custom with @cabal-version >  $our-cabal-version@+--  4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@+--+-- It's also worth noting that packages specifying @cabal-version: >= 1.23@+-- or later that have @build-type@ Custom will always have a @custom-setup@+-- section. Therefore in case 2, the specified @cabal-version@ will always be+-- less than 1.23.+--+-- In cases 1 and 2 we obviously have to build an external Setup.hs script,+-- while in case 4 we can use the internal library API. In case 3 we also have+-- to build an external Setup.hs script because the package needs a later+-- Cabal lib version than we can support internally.+--+data SetupScriptStyle = SetupCustomExplicitDeps+                      | SetupCustomImplicitDeps+                      | SetupNonCustomExternalLib+                      | SetupNonCustomInternalLib+  deriving (Eq, Show, Generic, Typeable)++instance Binary SetupScriptStyle+instance Structured SetupScriptStyle
+ src/Distribution/Client/RebuildMonad.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-}++-- | An abstraction for re-running actions if values or files have changed.+--+-- This is not a full-blown make-style incremental build system, it's a bit+-- more ad-hoc than that, but it's easier to integrate with existing code.+--+-- It's a convenient interface to the "Distribution.Client.FileMonitor"+-- functions.+--+module Distribution.Client.RebuildMonad (+    -- * Rebuild monad+    Rebuild,+    runRebuild,+    execRebuild,+    askRoot,++    -- * Setting up file monitoring+    monitorFiles,+    MonitorFilePath,+    monitorFile,+    monitorFileHashed,+    monitorNonExistentFile,+    monitorDirectory,+    monitorNonExistentDirectory,+    monitorDirectoryExistence,+    monitorFileOrDirectory,+    monitorFileSearchPath,+    monitorFileHashedSearchPath,+    -- ** Monitoring file globs+    monitorFileGlob,+    monitorFileGlobExistence,+    FilePathGlob(..),+    FilePathRoot(..),+    FilePathGlobRel(..),+    GlobPiece(..),++    -- * Using a file monitor+    FileMonitor(..),+    newFileMonitor,+    rerunIfChanged,++    -- * Utils+    delayInitSharedResource,+    delayInitSharedResources,+    matchFileGlob,+    getDirectoryContentsMonitored,+    createDirectoryMonitored,+    monitorDirectoryStatus,+    doesFileExistMonitored,+    need,+    needIfExists,+    findFileWithExtensionMonitored,+    findFirstFileMonitored,+    findFileMonitored,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.FileMonitor+import Distribution.Client.Glob hiding (matchFileGlob)+import qualified Distribution.Client.Glob as Glob (matchFileGlob)++import Distribution.Simple.Utils (debug)++import qualified Data.Map.Strict as Map+import Control.Monad.State as State+import Control.Monad.Reader as Reader+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)+import System.FilePath+import System.Directory+++-- | A monad layered on top of 'IO' to help with re-running actions when the+-- input files and values they depend on change. The crucial operations are+-- 'rerunIfChanged' and 'monitorFiles'.+--+newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)+  deriving (Functor, Applicative, Monad, MonadIO)++-- | Use this wihin the body action of 'rerunIfChanged' to declare that the+-- action depends on the given files. This can be based on what the action+-- actually did. It is these files that will be checked for changes next+-- time 'rerunIfChanged' is called for that 'FileMonitor'.+--+-- Relative paths are interpreted as relative to an implicit root, ultimately+-- passed in to 'runRebuild'.+--+monitorFiles :: [MonitorFilePath] -> Rebuild ()+monitorFiles filespecs = Rebuild (State.modify (filespecs++))++-- | Run a 'Rebuild' IO action.+unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])+unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) []++-- | Run a 'Rebuild' IO action.+runRebuild :: FilePath -> Rebuild a -> IO a+runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) []++-- | Run a 'Rebuild' IO action.+execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath]+execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) []++-- | The root that relative paths are interpreted as being relative to.+askRoot :: Rebuild FilePath+askRoot = Rebuild Reader.ask++-- | This captures the standard use pattern for a 'FileMonitor': given a+-- monitor, an action and the input value the action depends on, either+-- re-run the action to get its output, or if the value and files the action+-- depends on have not changed then return a previously cached action result.+--+-- The result is still in the 'Rebuild' monad, so these can be nested.+--+-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.+--+rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b)+               => Verbosity+               -> FileMonitor a b+               -> a+               -> Rebuild b+               -> Rebuild b+rerunIfChanged verbosity monitor key action = do+    rootDir <- askRoot+    changed <- liftIO $ checkFileMonitorChanged monitor rootDir key+    case changed of+      MonitorUnchanged result files -> do+        liftIO $ debug verbosity $ "File monitor '" ++ monitorName+                                                    ++ "' unchanged."+        monitorFiles files+        return result++      MonitorChanged reason -> do+        liftIO $ debug verbosity $ "File monitor '" ++ monitorName+                                ++ "' changed: " ++ showReason reason+        startTime <- liftIO $ beginUpdateFileMonitor+        (result, files) <- liftIO $ unRebuild rootDir action+        liftIO $ updateFileMonitor monitor rootDir+                                   (Just startTime) files key result+        monitorFiles files+        return result+  where+    monitorName = takeFileName (fileMonitorCacheFile monitor)++    showReason (MonitoredFileChanged file) = "file " ++ file+    showReason (MonitoredValueChanged _)   = "monitor value changed"+    showReason  MonitorFirstRun            = "first run"+    showReason  MonitorCorruptCache        = "invalid cache file"+++-- | When using 'rerunIfChanged' for each element of a list of actions, it is+-- sometimes the case that each action needs to make use of some resource. e.g.+--+-- > sequence+-- >   [ rerunIfChanged verbosity monitor key $ do+-- >       resource <- mkResource+-- >       ... -- use the resource+-- >   | ... ]+--+-- For efficiency one would like to share the resource between the actions+-- but the straightforward way of doing this means initialising it every time+-- even when no actions need re-running.+--+-- > resource <- mkResource+-- > sequence+-- >   [ rerunIfChanged verbosity monitor key $ do+-- >       ... -- use the resource+-- >   | ... ]+--+-- This utility allows one to get the best of both worlds:+--+-- > getResource <- delayInitSharedResource mkResource+-- > sequence+-- >   [ rerunIfChanged verbosity monitor key $ do+-- >       resource <- getResource+-- >       ... -- use the resource+-- >   | ... ]+--+delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)+delayInitSharedResource action = do+    var <- liftIO (newMVar Nothing)+    return (liftIO (getOrInitResource var))+  where+    getOrInitResource :: MVar (Maybe a) -> IO a+    getOrInitResource var =+      modifyMVar var $ \mx ->+        case mx of+          Just x  -> return (Just x, x)+          Nothing -> do+            x <- action+            return (Just x, x)+++-- | Much like 'delayInitSharedResource' but for a keyed set of resources.+--+-- > getResource <- delayInitSharedResource mkResource+-- > sequence+-- >   [ rerunIfChanged verbosity monitor key $ do+-- >       resource <- getResource key+-- >       ... -- use the resource+-- >   | ... ]+--+delayInitSharedResources :: forall k v. Ord k+                         => (k -> IO v)+                         -> Rebuild (k -> Rebuild v)+delayInitSharedResources action = do+    var <- liftIO (newMVar Map.empty)+    return (liftIO . getOrInitResource var)+  where+    getOrInitResource :: MVar (Map k v) -> k -> IO v+    getOrInitResource var k =+      modifyMVar var $ \m ->+        case Map.lookup k m of+          Just x  -> return (m, x)+          Nothing -> do+            x <- action k+            let !m' = Map.insert k x m+            return (m', x)+++-- | Utility to match a file glob against the file system, starting from a+-- given root directory. The results are all relative to the given root.+--+-- Since this operates in the 'Rebuild' monad, it also monitors the given glob+-- for changes.+--+matchFileGlob :: FilePathGlob -> Rebuild [FilePath]+matchFileGlob glob = do+    root <- askRoot+    monitorFiles [monitorFileGlobExistence glob]+    liftIO $ Glob.matchFileGlob root glob++getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]+getDirectoryContentsMonitored dir = do+    exists <- monitorDirectoryStatus dir+    if exists+      then liftIO $ getDirectoryContents dir+      else return []++createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()+createDirectoryMonitored createParents dir = do+    monitorFiles [monitorDirectoryExistence dir]+    liftIO $ createDirectoryIfMissing createParents dir++-- | Monitor a directory as in 'monitorDirectory' if it currently exists or+-- as 'monitorNonExistentDirectory' if it does not.+monitorDirectoryStatus :: FilePath -> Rebuild Bool+monitorDirectoryStatus dir = do+    exists <- liftIO $ doesDirectoryExist dir+    monitorFiles [if exists+                    then monitorDirectory dir+                    else monitorNonExistentDirectory dir]+    return exists++-- | Like 'doesFileExist', but in the 'Rebuild' monad.  This does+-- NOT track the contents of 'FilePath'; use 'need' in that case.+doesFileExistMonitored :: FilePath -> Rebuild Bool+doesFileExistMonitored f = do+    root <- askRoot+    exists <- liftIO $ doesFileExist (root </> f)+    monitorFiles [if exists+                    then monitorFileExistence f+                    else monitorNonExistentFile f]+    return exists++-- | Monitor a single file+need :: FilePath -> Rebuild ()+need f = monitorFiles [monitorFileHashed f]++-- | Monitor a file if it exists; otherwise check for when it+-- gets created.  This is a bit better for recompilation avoidance+-- because sometimes users give bad package metadata, and we don't+-- want to repeatedly rebuild in this case (which we would if we+-- need'ed a non-existent file).+needIfExists :: FilePath -> Rebuild ()+needIfExists f = do+    root <- askRoot+    exists <- liftIO $ doesFileExist (root </> f)+    monitorFiles [if exists+                    then monitorFileHashed f+                    else monitorNonExistentFile f]++-- | Like 'findFileWithExtension', but in the 'Rebuild' monad.+findFileWithExtensionMonitored+    :: [String]+    -> [FilePath]+    -> FilePath+    -> Rebuild (Maybe FilePath)+findFileWithExtensionMonitored extensions searchPath baseName =+  findFirstFileMonitored id+    [ path </> baseName <.> ext+    | path <- nub searchPath+    , ext <- nub extensions ]++-- | Like 'findFirstFile', but in the 'Rebuild' monad.+findFirstFileMonitored :: (a -> FilePath) -> [a] -> Rebuild (Maybe a)+findFirstFileMonitored file = findFirst+  where findFirst []     = return Nothing+        findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)+                              if exists+                                then return (Just x)+                                else findFirst xs++-- | Like 'findFile', but in the 'Rebuild' monad.+findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)+findFileMonitored searchPath fileName =+  findFirstFileMonitored id+    [ path </> fileName+    | path <- nub searchPath]
+ src/Distribution/Client/Reconfigure.hs view
@@ -0,0 +1,179 @@+module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where++import Distribution.Client.Compat.Prelude++import Data.Monoid ( Any(..) )+import System.Directory ( doesFileExist )++import Distribution.Simple.Configure ( localBuildInfoFile )+import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag )+import Distribution.Simple.Utils+       ( existsAndIsMoreRecentThan, defaultPackageDesc, info )++import Distribution.Client.Config ( SavedConfig(..) )+import Distribution.Client.Configure ( readConfigFlags )+import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate )+import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs )+import Distribution.Client.Sandbox.PackageEnvironment+       ( userPackageEnvironmentFile )+import Distribution.Client.Setup+       ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) )++-- | @Check@ represents a function to check some condition on type @a@. The+-- returned 'Any' is 'True' if any part of the condition failed.+newtype Check a = Check {+  runCheck :: Any          -- Did any previous check fail?+           -> a            -- value returned by previous checks+           -> IO (Any, a)  -- Did this check fail? What value is returned?+}++instance Semigroup (Check a) where+  (<>) c d = Check $ \any0 a0 -> do+    (any1, a1) <- runCheck c any0 a0+    (any2, a2) <- runCheck d (any0 <> any1) a1+    return (any0 <> any1 <> any2, a2)++instance Monoid (Check a) where+  mempty = Check $ \_ a -> return (mempty, a)+  mappend = (<>)+++-- | Re-configure the package in the current directory if needed. Deciding+-- when to reconfigure and with which options is convoluted:+--+-- If we are reconfiguring, we must always run @configure@ with the+-- verbosity option we are given; however, that a previous configuration+-- uses a different verbosity setting is not reason enough to reconfigure.+--+-- The package should be configured to use the same \"dist\" prefix as+-- given to the @build@ command, otherwise the build will probably+-- fail. Not only does this determine the \"dist\" prefix setting if we+-- need to reconfigure anyway, but an existing configuration should be+-- invalidated if its \"dist\" prefix differs.+--+-- If the package has never been configured (i.e., there is no+-- LocalBuildInfo), we must configure first, using the default options.+--+-- If the package has been configured, there will be a 'LocalBuildInfo'.+-- If there no package description file, we assume that the+-- 'PackageDescription' is up to date, though the configuration may need+-- to be updated for other reasons (see above). If there is a package+-- description file, and it has been modified since the 'LocalBuildInfo'+-- was generated, then we need to reconfigure.+--+-- The caller of this function may also have specific requirements+-- regarding the flags the last configuration used. For example,+-- 'testAction' requires that the package be configured with test suites+-- enabled. The caller may pass the required settings to this function+-- along with a function to check the validity of the saved 'ConfigFlags';+-- these required settings will be checked first upon determining that+-- a previous configuration exists.+reconfigure+  :: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())+     -- ^ configure action+  -> Verbosity+     -- ^ Verbosity setting+  -> FilePath+     -- ^ \"dist\" prefix+  -> Flag (Maybe Int)+     -- ^ -j flag for reinstalling add-source deps.+  -> Check (ConfigFlags, ConfigExFlags)+     -- ^ Check that the required flags are set.+     -- If they are not set, provide a message explaining the+     -- reason for reconfiguration.+  -> [String]     -- ^ Extra arguments+  -> GlobalFlags  -- ^ Global flags+  -> SavedConfig+  -> IO SavedConfig+reconfigure+  configureAction+  verbosity+  dist+  _numJobsFlag+  check+  extraArgs+  globalFlags+  config+  = do++  savedFlags@(_, _) <- readConfigFlags dist++  useNix <- fmap isJust (findNixExpr globalFlags config)+  alreadyInNixShell <- inNixShell++  if useNix && not alreadyInNixShell+    then do++      -- If we are using Nix, we must reinstantiate the derivation outside+      -- the shell. Eventually, the caller will invoke 'nixShell' which will+      -- rerun cabal inside the shell. That will bring us back to 'reconfigure',+      -- but inside the shell we'll take the second branch, below.++      -- This seems to have a problem: won't 'configureAction' call 'nixShell'+      -- yet again, spawning an infinite tree of subprocesses?+      -- No, because 'nixShell' doesn't spawn a new process if it is already+      -- running in a Nix shell.++      nixInstantiate verbosity dist False globalFlags config+      return config++    else do++      let checks =+            checkVerb+            <> checkDist+            <> checkOutdated+            <> check+      (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags++      let config' = updateInstallDirs (configUserInstall configFlags) config++      when frc $ configureAction flags extraArgs globalFlags+      return config'++  where++    -- Changing the verbosity does not require reconfiguration, but the new+    -- verbosity should be used if reconfiguring.+    checkVerb = Check $ \_ (configFlags, configExFlags) -> do+      let configFlags' = configFlags { configVerbosity = toFlag verbosity}+      return (mempty, (configFlags', configExFlags))++    -- Reconfiguration is required if @--build-dir@ changes.+    checkDist = Check $ \_ (configFlags, configExFlags) -> do+      -- Always set the chosen @--build-dir@ before saving the flags,+      -- or bad things could happen.+      savedDist <- findSavedDistPref config (configDistPref configFlags)+      let distChanged = dist /= savedDist+      when distChanged $ info verbosity "build directory changed"+      let configFlags' = configFlags { configDistPref = toFlag dist }+      return (Any distChanged, (configFlags', configExFlags))++    checkOutdated = Check $ \_ flags@(configFlags, _) -> do+      let buildConfig = localBuildInfoFile dist++      -- Has the package ever been configured? If not, reconfiguration is+      -- required.+      configured <- doesFileExist buildConfig+      unless configured $ info verbosity "package has never been configured"++      -- 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@+      -- even without sandboxes.+      userPackageEnvironmentFileModified <-+        existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig+      when userPackageEnvironmentFileModified $+        info verbosity ("user package environment file ('"+        ++ userPackageEnvironmentFile ++ "') was modified")++      -- Is the configuration older than the package description?+      descrFile <- maybe (defaultPackageDesc verbosity) return+                   (flagToMaybe (configCabalFilePath configFlags))+      outdated <- existsAndIsMoreRecentThan descrFile buildConfig+      when outdated $ info verbosity (descrFile ++ " was changed")++      let failed =+            Any outdated+            <> Any userPackageEnvironmentFileModified+            <> Any (not configured)+      return (failed, flags)
+ src/Distribution/Client/Run.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Run+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'run' command.+-----------------------------------------------------------------------------++module Distribution.Client.Run ( run, splitRunArgs )+       where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Types.TargetInfo     (targetCLBI)+import Distribution.Types.LocalBuildInfo (componentNameTargets')++import Distribution.Client.Utils             (tryCanonicalizePath)++import Distribution.Types.UnqualComponentName+import Distribution.PackageDescription       (Executable (..),+                                              TestSuite(..),+                                              Benchmark(..),+                                              PackageDescription (..),+                                              BuildInfo(buildable))+import Distribution.Simple.Compiler          (compilerFlavor, CompilerFlavor(..))+import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)+import Distribution.Simple.BuildPaths        (exeExtension)+import Distribution.Simple.LocalBuildInfo    (ComponentName (..),+                                              LocalBuildInfo (..),+                                              depLibraryPaths)+import Distribution.Simple.Utils             (die', notice, warn,+                                              rawSystemExitWithEnv,+                                              addLibraryPath)+import Distribution.System                   (Platform (..))++import qualified Distribution.Simple.GHCJS as GHCJS++import System.Directory                      (getCurrentDirectory)+import Distribution.Compat.Environment       (getEnvironment)+import System.FilePath                       ((<.>), (</>))+++-- | Return the executable to run and any extra arguments that should be+-- forwarded to it. Die in case of error.+splitRunArgs :: Verbosity -> LocalBuildInfo -> [String]+             -> IO (Executable, [String])+splitRunArgs verbosity lbi args =+  case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)+    Left err               -> do+      warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.+      die' verbosity err+    Right (True, exe, xs)  -> return (exe, xs)+    Right (False, exe, xs) -> do+      let addition = " Interpreting all parameters to `run` as a parameter to"+                     ++ " the default executable."+      -- If there is a warning, print it together with the addition.+      warn verbosity `traverse_` fmap (++addition) maybeWarning+      return (exe, xs)+  where+    pkg_descr = localPkgDescr lbi+    whichExecutable :: Either String       -- Error string.+                              ( Bool       -- If it was manually chosen.+                              , Executable -- The executable.+                              , [String]   -- The remaining parameters.+                              )+    whichExecutable = case (enabledExes, args) of+      ([]   , _)           -> Left "Couldn't find any enabled executables."+      ([exe], [])          -> return (False, exe, [])+      ([exe], (x:xs))+        | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)+        | otherwise                                -> return (False, exe, args)+      (_    , [])                                  -> Left+        $ "This package contains multiple executables. "+        ++ "You must pass the executable name as the first argument "+        ++ "to 'cabal run'."+      (_    , (x:xs))      ->+        case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of+          Nothing  -> Left $ "No executable named '" ++ x ++ "'."+          Just exe -> return (True, exe, xs)+      where+        enabledExes = filter (buildable . buildInfo) (executables pkg_descr)++    maybeWarning :: Maybe String+    maybeWarning = case args of+      []    -> Nothing+      (x:_) -> lookup (mkUnqualComponentName x) components+      where+        components :: [(UnqualComponentName, String)] -- Component name, message.+        components =+          [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.")+          | e <- executables pkg_descr+          , not . buildable . buildInfo $ e, let name = exeName e]++          ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "',"+                      ++ " but the `run` command is only for executables.")+             | t <- testSuites pkg_descr+             , let name = testName t]++          ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "',"+                      ++ " but the `run` command is only for executables.")+             | b <- benchmarks pkg_descr+             , let name = benchmarkName b]++-- | Run a given executable.+run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()+run verbosity lbi exe exeArgs = do+  curDir <- getCurrentDirectory+  let buildPref     = buildDir lbi+      pkg_descr     = localPkgDescr lbi+      dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",+                       curDir </> dataDir pkg_descr)++  (path, runArgs) <-+    let exeName' = prettyShow $ exeName exe+    in case compilerFlavor (compiler lbi) of+      GHCJS -> do+        let (script, cmd, cmdArgs) =+              GHCJS.runCmd (withPrograms lbi)+                           (buildPref </> exeName' </> exeName')+        script' <- tryCanonicalizePath script+        return (cmd, cmdArgs ++ [script'])+      _     -> do+         p <- tryCanonicalizePath $+            buildPref </> exeName' </> (exeName' <.> exeExtension (hostPlatform lbi))+         return (p, [])++  env  <- (dataDirEnvVar:) <$> getEnvironment+  -- Add (DY)LD_LIBRARY_PATH if needed+  env' <- if withDynExe lbi+             then do let (Platform _ os) = hostPlatform lbi+                     clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of+                                [target] -> return (targetCLBI target)+                                [] -> die' verbosity "run: Could not find executable in LocalBuildInfo"+                                _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo"+                     paths <- depLibraryPaths True False lbi clbi+                     return (addLibraryPath os paths env)+             else return env+  notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..."+  rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'
+ src/Distribution/Client/Sandbox.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- UI for the sandboxing functionality.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox (+    loadConfigOrSandboxConfig,+    findSavedDistPref,++    updateInstallDirs,++    getPersistOrConfigCompiler+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Client.Setup+  ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' )+import Distribution.Client.Config+  ( SavedConfig(..), defaultUserInstall, loadConfig )++import Distribution.Client.Sandbox.PackageEnvironment+  (  PackageEnvironmentType(..)+  , classifyPackageEnvironment+  , loadUserConfig+  )+import Distribution.Client.SetupWrapper+  ( SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Simple.Compiler           ( Compiler(..) )+import Distribution.Simple.Configure          ( maybeGetPersistBuildConfig+                                              , findDistPrefOrDefault+                                              , findDistPref )+import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo+import Distribution.Simple.Program            ( ProgramDb )+import Distribution.Simple.Setup              ( Flag(..)+                                              , fromFlagOrDefault, flagToMaybe )+import Distribution.System                    ( Platform )++import System.Directory                       ( getCurrentDirectory )+++-- * Basic sandbox functions.+--++updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig+updateInstallDirs userInstallFlag savedConfig = savedConfig+    { savedConfigureFlags = configureFlags+        { configInstallDirs = installDirs+        }+    }+  where+    configureFlags = savedConfigureFlags savedConfig+    userInstallDirs = savedUserInstallDirs savedConfig+    globalInstallDirs = savedGlobalInstallDirs savedConfig+    installDirs | userInstall = userInstallDirs+                | otherwise   = globalInstallDirs+    userInstall = fromFlagOrDefault defaultUserInstall+                  (configUserInstall configureFlags `mappend` userInstallFlag)++-- | Check which type of package environment we're in and return a+-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates+-- whether we're working in a sandbox.+loadConfigOrSandboxConfig :: Verbosity+                          -> GlobalFlags  -- ^ For @--config-file@ and+                                          -- @--sandbox-config-file@.+                          -> IO SavedConfig+loadConfigOrSandboxConfig verbosity globalFlags = do+  let configFileFlag        = globalConfigFile        globalFlags++  pkgEnvDir  <- getCurrentDirectory+  pkgEnvType <- classifyPackageEnvironment pkgEnvDir+  case pkgEnvType of+    -- Only @cabal.config@ is present.+    UserPackageEnvironment    -> do+      config <- loadConfig verbosity configFileFlag+      userConfig <- loadUserConfig verbosity pkgEnvDir Nothing+      let config' = config `mappend` userConfig+      return config'++    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.+    AmbientPackageEnvironment -> do+      config <- loadConfig verbosity configFileFlag+      let globalConstraintsOpt =+            flagToMaybe . globalConstraintsFile . savedGlobalFlags $ config+      globalConstraintConfig <-+        loadUserConfig verbosity pkgEnvDir globalConstraintsOpt+      let config' = config `mappend` globalConstraintConfig+      return config'++-- | Return the saved \"dist/\" prefix, or the default prefix.+findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath+findSavedDistPref config flagDistPref = do+    let defDistPref = useDistPref defaultSetupScriptOptions+        flagDistPref' = configDistPref (savedConfigureFlags config)+                        `mappend` flagDistPref+    findDistPref defDistPref flagDistPref'++-- Utils (transitionary)+--++-- | Try to read the most recently configured compiler from the+-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it+-- cannot be read.+getPersistOrConfigCompiler :: ConfigFlags+                           -> IO (Compiler, Platform, ProgramDb)+getPersistOrConfigCompiler configFlags = do+  distPref <- findDistPrefOrDefault (configDistPref configFlags)+  mlbi <- maybeGetPersistBuildConfig distPref+  case mlbi of+    Nothing  -> do configCompilerAux' configFlags+    Just lbi -> return ( LocalBuildInfo.compiler lbi+                       , LocalBuildInfo.hostPlatform lbi+                       , LocalBuildInfo.withPrograms lbi+                       )
+ src/Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE DeriveGeneric #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.PackageEnvironment+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Utilities for working with the package environment file. Patterned after+-- Distribution.Client.Config.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.PackageEnvironment (+    PackageEnvironment(..)+  , PackageEnvironmentType(..)+  , classifyPackageEnvironment+  , readPackageEnvironmentFile+  , showPackageEnvironment+  , showPackageEnvironmentWithComments+  , loadUserConfig++  , userPackageEnvironmentFile+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.Config      ( SavedConfig(..) +                                       , configFieldDescriptions+                                       , haddockFlagsFields+                                       , installDirsFields, withProgramsFields+                                       , withProgramOptionsFields+                                       )+import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )+import Distribution.Client.Setup       ( ConfigExFlags(..)+                                       )+import Distribution.Client.Targets     ( userConstraintPackageName )+import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate )+import Distribution.Simple.Setup       ( Flag(..)+                                       , ConfigFlags(..), HaddockFlags(..)+                                       )+import Distribution.Simple.Utils       ( warn, debug )+import Distribution.Solver.Types.ConstraintSource+import Distribution.Deprecated.ParseUtils         ( FieldDescr(..), ParseResult(..)+                                       , commaListFieldParsec, commaNewLineListFieldParsec+                                       , liftField, lineNo, locatedErrorMsg+                                       , readFields+                                       , showPWarning +                                       , syntaxError, warning )+import System.Directory                ( doesFileExist )+import System.FilePath                 ( (</>) )+import System.IO.Error                 ( isDoesNotExistError )+import Text.PrettyPrint                ( ($+$) )++import qualified Data.ByteString as BS+import qualified Text.PrettyPrint          as Disp+import qualified Distribution.Deprecated.ParseUtils   as ParseUtils ( Field(..) )++--+-- * Configuration saved in the package environment file+--++-- TODO: would be nice to remove duplication between+-- D.C.Sandbox.PackageEnvironment and D.C.Config.+data PackageEnvironment = PackageEnvironment {+  pkgEnvSavedConfig   :: SavedConfig+} deriving Generic++instance Monoid PackageEnvironment where+  mempty = gmempty+  mappend = (<>)++instance Semigroup PackageEnvironment where+  (<>) = gmappend++-- | Optional package environment file that can be used to customize the default+-- settings. Created by the user.+userPackageEnvironmentFile :: FilePath+userPackageEnvironmentFile = "cabal.config"++-- | Type of the current package environment.+data PackageEnvironmentType+  = UserPackageEnvironment    -- ^ './cabal.config'+  | AmbientPackageEnvironment -- ^ '~/.cabal/config'++-- | Is there a 'cabal.config' in this directory?+classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType+classifyPackageEnvironment pkgEnvDir = do+     isUser <- configExists userPackageEnvironmentFile+     return (classify isUser)+  where+    configExists fname   = doesFileExist (pkgEnvDir </> fname)++    classify :: Bool -> PackageEnvironmentType+    classify True    = UserPackageEnvironment+    classify False   = AmbientPackageEnvironment+++-- | Load the user package environment if it exists (the optional "cabal.config"+-- file). If it does not exist locally, attempt to load an optional global one.+userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath+                       -> IO PackageEnvironment+userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do+    let path = pkgEnvDir </> userPackageEnvironmentFile+    minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path)+            mempty path+    case (minp, globalConfigLocation) of+      (Just parseRes, _)  -> processConfigParse path parseRes+      (_, Just globalLoc) -> do+        minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc)+                 mempty globalLoc+        maybe (warn verbosity ("no constraints file found at " ++ globalLoc)+               >> return mempty)+          (processConfigParse globalLoc)+          minp'+      _ -> do+        debug verbosity ("no user package environment file found at " ++ pkgEnvDir)+        return mempty+  where+    processConfigParse path (ParseOk warns parseResult) = do+      unless (null warns) $ warn verbosity $+        unlines (map (showPWarning path) warns)+      return parseResult+    processConfigParse path (ParseFailed err) = do+      let (line, msg) = locatedErrorMsg err+      warn verbosity $ "Error parsing package environment file " ++ path+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg+      return mempty++-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.+loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig+loadUserConfig verbosity pkgEnvDir globalConfigLocation =+    fmap pkgEnvSavedConfig $+    userPackageEnvironment verbosity pkgEnvDir globalConfigLocation++++-- | Descriptions of all fields in the package environment file.+pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]+pkgEnvFieldDescrs src =+  [ commaNewLineListFieldParsec "constraints"+    (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec)+    (sortConstraints . configExConstraints+     . savedConfigureExFlags . pkgEnvSavedConfig)+    (\v pkgEnv -> updateConfigureExFlags pkgEnv+                  (\flags -> flags { configExConstraints = v }))++  , commaListFieldParsec "preferences"+    pretty parsec+    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)+    (\v pkgEnv -> updateConfigureExFlags pkgEnv+                  (\flags -> flags { configPreferences = v }))+  ]+  ++ map toPkgEnv configFieldDescriptions'+  where+    configFieldDescriptions' :: [FieldDescr SavedConfig]+    configFieldDescriptions' = filter+      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")+      (configFieldDescriptions src)++    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment+    toPkgEnv fieldDescr =+      liftField pkgEnvSavedConfig+      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})+      fieldDescr++    updateConfigureExFlags :: PackageEnvironment+                              -> (ConfigExFlags -> ConfigExFlags)+                              -> PackageEnvironment+    updateConfigureExFlags pkgEnv f = pkgEnv {+      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {+         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig+                                 $ pkgEnv+         }+      }++    sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)++-- | Read the package environment file.+readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath+                              -> IO (Maybe (ParseResult PackageEnvironment))+readPackageEnvironmentFile src initial file =+  handleNotExists $+  fmap (Just . parsePackageEnvironment src initial) (BS.readFile file)+  where+    handleNotExists action = catchIO action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++-- | Parse the package environment file.+parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString+                           -> ParseResult PackageEnvironment+parsePackageEnvironment src initial str = do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  pkgEnv <- parse others+  let config       = pkgEnvSavedConfig pkgEnv+      installDirs0 = savedUserInstallDirs config+  (haddockFlags, installDirs, paths, args) <-+    foldM parseSections+    (savedHaddockFlags config, installDirs0, [], [])+    knownSections+  return pkgEnv {+    pkgEnvSavedConfig = config {+       savedConfigureFlags    = (savedConfigureFlags config) {+          configProgramPaths  = paths,+          configProgramArgs   = args+          },+       savedHaddockFlags      = haddockFlags,+       savedUserInstallDirs   = installDirs,+       savedGlobalInstallDirs = installDirs+       }+    }++  where+    isKnownSection :: ParseUtils.Field -> Bool+    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 src) initial++    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."+    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])])++++-- | Pretty-print the package environment.+showPackageEnvironment :: PackageEnvironment -> String+showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv++-- | Pretty-print the package environment with default values for empty fields+-- commented out (just like the default ~/.cabal/config).+showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)+                                      -> PackageEnvironment+                                      -> String+showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $+      ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)+               mdefPkgEnv pkgEnv+  $+$ Disp.text ""+  $+$ ppSection "install-dirs" "" installDirsFields+                (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)+  where+    installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig
+ src/Distribution/Client/SavedFlags.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Distribution.Client.SavedFlags+       ( readCommandFlags, writeCommandFlags+       , readSavedArgs, writeSavedArgs+       ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Simple.Command+import Distribution.Simple.UserHooks ( Args )+import Distribution.Simple.Utils+       ( createDirectoryIfMissingVerbose, unintersperse )+import Distribution.Verbosity++import System.Directory ( doesFileExist )+import System.FilePath ( takeDirectory )+++writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO ()+writeSavedArgs verbosity path args = do+  createDirectoryIfMissingVerbose+    (lessVerbose verbosity) True (takeDirectory path)+  writeFile path (intercalate "\0" args)+++-- | Write command-line flags to a file, separated by null characters. This+-- format is also suitable for the @xargs -0@ command. Using the null+-- character also avoids the problem of escaping newlines or spaces,+-- because unlike other whitespace characters, the null character is+-- not valid in command-line arguments.+writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO ()+writeCommandFlags verbosity path command flags =+  writeSavedArgs verbosity path (commandShowOptions command flags)+++readSavedArgs :: FilePath -> IO (Maybe [String])+readSavedArgs path = do+  exists <- doesFileExist path+  if exists+     then fmap (Just . unintersperse '\0') (readFile path)+    else return Nothing+++-- | Read command-line arguments, separated by null characters, from a file.+-- Returns the default flags if the file does not exist.+readCommandFlags :: FilePath -> CommandUI flags -> IO flags+readCommandFlags path command = do+  savedArgs <- fmap (fromMaybe []) (readSavedArgs path)+  case (commandParseArgs command True savedArgs) of+    CommandHelp _ -> throwIO (SavedArgsErrorHelp savedArgs)+    CommandList _ -> throwIO (SavedArgsErrorList savedArgs)+    CommandErrors errs -> throwIO (SavedArgsErrorOther savedArgs errs)+    CommandReadyToGo (mkFlags, _) ->+      return (mkFlags (commandDefaultFlags command))++-- -----------------------------------------------------------------------------+-- * Exceptions+-- -----------------------------------------------------------------------------++data SavedArgsError+    = SavedArgsErrorHelp Args+    | SavedArgsErrorList Args+    | SavedArgsErrorOther Args [String]+  deriving (Typeable)++instance Show SavedArgsError where+  show (SavedArgsErrorHelp args) =+    "unexpected flag '--help', saved command line was:\n"+    ++ intercalate " " args+  show (SavedArgsErrorList args) =+    "unexpected flag '--list-options', saved command line was:\n"+    ++ intercalate " " args+  show (SavedArgsErrorOther args errs) =+    "saved command line was:\n"+    ++ intercalate " " args ++ "\n"+    ++ "encountered errors:\n"+    ++ intercalate "\n" errs++instance Exception SavedArgsError
+ src/Distribution/Client/Security/DNS.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP #-}++module Distribution.Client.Security.DNS+    ( queryBootstrapMirrors+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude+import Network.URI (URI(..), URIAuth(..), parseURI)+import Control.Exception (try)+import Distribution.Simple.Utils++#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)+import Network.DNS (queryTXT, Name(..), CharStr(..))+import qualified Data.ByteString.Char8 as BS.Char8+#else+import Distribution.Simple.Program.Db+         ( emptyProgramDb, addKnownProgram+         , configureAllKnownPrograms, lookupProgram )+import Distribution.Simple.Program+         ( simpleProgram+         , programInvocation+         , getProgramInvocationOutput )+#endif++-- | Try to lookup RFC1464-encoded mirror urls for a Hackage+-- repository url by performing a DNS TXT lookup on the+-- @_mirrors.@-prefixed URL hostname.+--+-- Example: for @http://hackage.haskell.org/@+-- perform a DNS TXT query for the hostname+-- @_mirrors.hackage.haskell.org@ which may look like e.g.+--+-- > _mirrors.hackage.haskell.org. 300 IN TXT+-- >    "0.urlbase=http://hackage.fpcomplete.com/"+-- >    "1.urlbase=http://objects-us-west-1.dream.io/hackage-mirror/"+--+-- NB: hackage-security doesn't require DNS lookups being trustworthy,+-- as the trust is established via the cryptographically signed TUF+-- meta-data that is retrieved from the resolved Hackage repository.+-- Moreover, we already have to protect against a compromised+-- @hackage.haskell.org@ DNS entry, so an the additional+-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't+-- constitute a significant new attack vector anyway.+--+queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]++#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)+-- use @resolv@ package for performing DNS queries+queryBootstrapMirrors verbosity repoUri+  | Just auth <- uriAuthority repoUri = do+         let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth))++         mirrors' <- try $ do+                  txts <- queryTXT mirrorsDnsName+                  evaluate (force $ extractMirrors (map snd txts))++         mirrors <- case mirrors' of+             Left e -> do+                 warn verbosity ("Caught exception during _mirrors lookup:"+++                                 displayException (e :: SomeException))+                 return []+             Right v -> return v++         if null mirrors+         then warn verbosity ("No mirrors found for " ++ show repoUri)+         else do info verbosity ("located " ++ show (length mirrors) +++                                 " mirrors for " ++ show repoUri ++ " :")+                 for_ mirrors $ \url -> info verbosity ("- " ++ show url)++         return mirrors++  | otherwise = return []++-- | Extract list of mirrors from 'queryTXT' result+extractMirrors :: [[CharStr]] -> [URI]+extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals+  where+    vals = [ (kn,v) | CharStr e <- concat txtChunks+                    , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)]+                    , Just kn <- [isUrlBase k]+                    ]++----------------------------------------------------------------------------+#else /* !defined(MIN_VERSION_resolv) */+-- use external method via @nslookup@+queryBootstrapMirrors verbosity repoUri+  | Just auth <- uriAuthority repoUri = do+        progdb <- configureAllKnownPrograms verbosity $+                  addKnownProgram nslookupProg emptyProgramDb++        case lookupProgram nslookupProg progdb of+          Nothing -> do+              warn verbosity "'nslookup' tool missing - can't locate mirrors"+              return []++          Just nslookup -> do+              let mirrorsDnsName = "_mirrors." ++ uriRegName auth++              mirrors' <- try $ do+                  out <- getProgramInvocationOutput verbosity $+                         programInvocation nslookup ["-query=TXT", mirrorsDnsName]+                  evaluate (force $ extractMirrors mirrorsDnsName out)++              mirrors <- case mirrors' of+                Left e -> do+                    warn verbosity ("Caught exception during _mirrors lookup:"+++                                    displayException (e :: SomeException))+                    return []+                Right v -> return v++              if null mirrors+              then warn verbosity ("No mirrors found for " ++ show repoUri)+              else do info verbosity ("located " ++ show (length mirrors) +++                                      " mirrors for " ++ show repoUri ++ " :")+                      for_ mirrors $ \url -> info verbosity ("- " ++ show url)++              return mirrors++  | otherwise = return []+  where+    nslookupProg = simpleProgram "nslookup"++-- | Extract list of mirrors from @nslookup -query=TXT@ output.+extractMirrors :: String -> String -> [URI]+extractMirrors hostname s0 = mapMaybe (parseURI . snd) . sort $ vals+  where+    vals = [ (kn,v) | (h,ents) <- fromMaybe [] $ parseNsLookupTxt s0+                    , h == hostname+                    , e <- ents+                    , Just (k,v) <- [splitRfc1464 e]+                    , Just kn <- [isUrlBase k]+                    ]++-- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly+parseNsLookupTxt :: String -> Maybe [(String,[String])]+parseNsLookupTxt = go0 [] []+  where+    -- approximate grammar:+    -- <entries> := { <entry> }+    -- (<entry> starts at begin of line, but may span multiple lines)+    -- <entry> := ^ <hostname> TAB "text =" { <qstring> }+    -- <qstring> := string enclosed by '"'s ('\' and '"' are \-escaped)++    -- scan for ^ <word> <TAB> "text ="+    go0 []  _  []                                = Nothing+    go0 res _  []                                = Just (reverse res)+    go0 res _  ('\n':xs)                         = go0 res [] xs+    go0 res lw ('\t':'t':'e':'x':'t':' ':'=':xs) = go1 res (reverse lw) [] (dropWhile isSpace xs)+    go0 res lw (x:xs)                            = go0 res (x:lw) xs++    -- collect at least one <qstring>+    go1 res lw qs ('"':xs) = case qstr "" xs of+      Just (s, xs') -> go1 res lw (s:qs) (dropWhile isSpace xs')+      Nothing       -> Nothing -- bad quoting+    go1 _   _  [] _  = Nothing -- missing qstring+    go1 res lw qs xs = go0 ((lw,reverse qs):res) [] xs++    qstr _   ('\n':_) = Nothing -- We don't support unquoted LFs+    qstr acc ('\\':'\\':cs) = qstr ('\\':acc) cs+    qstr acc ('\\':'"':cs)  = qstr ('"':acc) cs+    qstr acc ('"':cs) = Just (reverse acc, cs)+    qstr acc (c:cs)   = qstr (c:acc) cs+    qstr _   []       = Nothing++#endif+----------------------------------------------------------------------------++-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data+isUrlBase :: String -> Maybe Int+isUrlBase s+  | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns+  | otherwise = Nothing+  where+    ns = take (length s - 8) s++-- | Split a TXT string into key and value according to RFC1464.+-- Returns 'Nothing' if parsing fails.+splitRfc1464 :: String -> Maybe (String,String)+splitRfc1464 = go ""+  where+    go _ [] = Nothing+    go acc ('`':c:cs) = go (c:acc) cs+    go acc ('=':cs)   = go2 (reverse acc) "" cs+    go acc (c:cs)+      | isSpace c = go acc cs+      | otherwise = go (c:acc) cs++    go2 k acc [] = Just (k,reverse acc)+    go2 _ _   ['`'] = Nothing+    go2 k acc ('`':c:cs) = go2 k (c:acc) cs+    go2 k acc (c:cs) = go2 k (c:acc) cs
+ src/Distribution/Client/Security/HTTP.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'+module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where++import Distribution.Solver.Compat.Prelude+import Prelude ()++-- stdlibs+import System.Directory+         ( getTemporaryDirectory )+import Network.URI+         ( URI )+import qualified Data.ByteString.Lazy as BS.L+import qualified Network.HTTP         as HTTP++-- Cabal/cabal-install+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Client.HttpUtils+         ( HttpTransport(..), HttpCode )+import Distribution.Client.Utils+         ( withTempFileName )++-- hackage-security+import           Hackage.Security.Client.Repository.HttpLib (HttpLib (..))+import qualified Hackage.Security.Client as HC+import qualified Hackage.Security.Client.Repository.HttpLib as HC+import qualified Hackage.Security.Util.Checked as HC+import qualified Hackage.Security.Util.Pretty as HC++{-------------------------------------------------------------------------------+  'HttpLib' implementation+-------------------------------------------------------------------------------}++-- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'+--+-- NOTE: The match between these two APIs is currently not perfect:+--+-- * We don't get any response headers back from the 'HttpTransport', so we+--   don't know if the server supports range requests. For now we optimistically+--   assume that it does.+-- * The 'HttpTransport' wants to know where to place the resulting file,+--   whereas the 'HttpLib' expects an 'IO' action which streams the download;+--   the security library then makes sure that the file gets written to a+--   location which is suitable (in particular, to a temporary file in the+--   directory where the file needs to end up, so that it can "finalize" the+--   file simply by doing 'renameFile'). Right now we write the file to a+--   temporary file in the system temp directory here and then read it again+--   to pass it to the security library; this is a problem for two reasons: it+--   is a source of inefficiency; and it means that the security library cannot+--   insist on a minimum download rate (potential security attack).+--   Fixing it however would require changing the 'HttpTransport'.+transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib+transportAdapter verbosity getTransport = HttpLib{+      httpGet      = \headers uri callback -> do+                        transport <- getTransport+                        httpGetImpl verbosity transport headers uri callback+    , httpGetRange = \headers uri range callback -> do+                        transport <- getTransport+                        getRange verbosity transport headers uri range callback+    }++httpGetImpl+    :: HC.Throws HC.SomeRemoteError+    => Verbosity+    -> HttpTransport+    -> [HC.HttpRequestHeader] -> URI+    -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)+    -> IO a+httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do+  get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->+    case code of+      200 -> callback respHeaders br+      _   -> HC.throwChecked $ UnexpectedResponse uri code++getRange :: HC.Throws HC.SomeRemoteError+         => Verbosity+         -> HttpTransport+         -> [HC.HttpRequestHeader] -> URI -> (Int, Int)+         -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)+         -> IO a+getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do+  get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->+    case code of+       200 -> callback HC.HttpStatus200OK             respHeaders br+       206 -> callback HC.HttpStatus206PartialContent respHeaders br+       _   -> HC.throwChecked $ UnexpectedResponse uri code++-- | Internal generalization of 'get' and 'getRange'+get' :: Verbosity+     -> HttpTransport+     -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int)+     -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)+     -> IO a+get' verbosity transport reqHeaders uri mRange callback = do+    tempDir <- getTemporaryDirectory+    withTempFileName tempDir "transportAdapterGet" $ \temp -> do+      (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'+      br <- HC.bodyReaderFromBS =<< BS.L.readFile temp+      callback code [HC.HttpResponseAcceptRangesBytes] br+  where+    reqHeaders' = mkReqHeaders reqHeaders mRange++{-------------------------------------------------------------------------------+  Request headers+-------------------------------------------------------------------------------}++mkRangeHeader :: Int -> Int -> HTTP.Header+mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader+  where+    -- Content-Range header uses inclusive rather than exclusive bounds+    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>+    rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)++mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]+mkReqHeaders reqHeaders mRange = concat [+      tr [] reqHeaders+    , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]+    ]+  where+    tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]+    tr acc [] =+      concatMap finalize acc+    tr acc (HC.HttpRequestMaxAge0:os) =+      tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os+    tr acc (HC.HttpRequestNoTransform:os) =+      tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os++    -- Some headers are comma-separated, others need multiple headers for+    -- multiple options.+    --+    -- TODO: Right we just comma-separate all of them.+    finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]+    finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))]++    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]+    insert x y = modifyAssocList x (++ y)++    -- modify the first matching element+    modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]+    modifyAssocList a f = go where+        go []                         = []+        go (p@(a', b) : xs) | a == a'   = (a', f b) : xs+                            | otherwise = p         : go xs++{-------------------------------------------------------------------------------+  Custom exceptions+-------------------------------------------------------------------------------}++data UnexpectedResponse = UnexpectedResponse URI Int+  deriving (Typeable)++instance HC.Pretty UnexpectedResponse where+  pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code+                                      ++ " for " ++ show uri++#if MIN_VERSION_base(4,8,0)+deriving instance Show UnexpectedResponse+instance Exception UnexpectedResponse where displayException = HC.pretty+#else+instance Show UnexpectedResponse where show = HC.pretty+instance Exception UnexpectedResponse+#endif++wrapCustomEx :: ( ( HC.Throws UnexpectedResponse+                  , HC.Throws IOException+                  ) => IO a)+             -> (HC.Throws HC.SomeRemoteError => IO a)+wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex)+                 $ HC.handleChecked (\(ex :: IOException)        -> go ex)+                 $ act+  where+    go ex = HC.throwChecked (HC.SomeRemoteError ex)
+ src/Distribution/Client/Setup.hs view
@@ -0,0 +1,2581 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE LambdaCase          #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Setup+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Setup+    ( globalCommand, GlobalFlags(..), defaultGlobalFlags+    , RepoContext(..), withRepoContext+    , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags+    , configPackageDB', configCompilerAux'+    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags+    , buildCommand, BuildFlags(..)+    , filterTestFlags+    , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions+                        , configureExOptions, reconfigureCommand+    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags+    , filterHaddockArgs, filterHaddockFlags, haddockOptions+    , defaultSolver, defaultMaxBackjumps+    , listCommand, ListFlags(..), listNeedsCompiler+    ,UpdateFlags(..), defaultUpdateFlags+    , infoCommand, InfoFlags(..)+    , fetchCommand, FetchFlags(..)+    , freezeCommand, FreezeFlags(..)+    , genBoundsCommand+    , outdatedCommand, OutdatedFlags(..), IgnoreMajorVersionBumps(..)+    , getCommand, unpackCommand, GetFlags(..)+    , checkCommand+    , formatCommand+    , uploadCommand, UploadFlags(..), IsCandidate(..)+    , reportCommand, ReportFlags(..)+    , runCommand+    , initCommand, initOptions, IT.InitFlags(..)+    , actAsSetupCommand, ActAsSetupFlags(..)+    , userConfigCommand, UserConfigFlags(..)+    , manpageCommand+    , haddockCommand+    , cleanCommand+    , copyCommand+    , registerCommand++    , liftOptions+    , yesNoOpt+    ) where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (get)++import Distribution.Client.Types.Credentials (Username (..), Password (..))+import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..))+import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..))+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy++import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Dependency.Types+         ( PreSolver(..) )+import Distribution.Client.IndexUtils.ActiveRepos+         ( ActiveRepos )+import Distribution.Client.IndexUtils.IndexState+         ( TotalIndexState, headTotalIndexState )+import qualified Distribution.Client.Init.Types as IT+         ( InitFlags(..), PackageType(..), defaultInitFlags )+import Distribution.Client.Targets+         ( UserConstraint, readUserConstraint )+import Distribution.Utils.NubList+         ( NubList, toNubList, fromNubList)++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.Settings++import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack )+import Distribution.Simple.Program (ProgramDb, defaultProgramDb)+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import qualified Distribution.Simple.Command as Command+import Distribution.Simple.Configure+       ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling )+import qualified Distribution.Simple.Setup as Cabal+import Distribution.Simple.Flag+         ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag+         , flagElim, fromFlagOrDefault+         )+import Distribution.Simple.Setup+         ( ConfigFlags(..), BuildFlags(..), ReplFlags+         , TestFlags, BenchmarkFlags+         , HaddockFlags(..)+         , CleanFlags(..)+         , CopyFlags(..), RegisterFlags(..)+         , readPackageDbList, showPackageDbList+         , BooleanFlag(..), optionVerbosity+         , boolOpt, boolOpt', trueArg, falseArg+         , optionNumJobs )+import Distribution.Simple.InstallDirs+         ( PathTemplate, InstallDirs(..)+         , toPathTemplate, fromPathTemplate, combinePathTemplate )+import Distribution.Version+         ( Version, mkVersion )+import Distribution.Package+         ( PackageName )+import Distribution.Types.GivenComponent+         ( GivenComponent(..) )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint(..) )+import Distribution.Types.UnqualComponentName+         ( unqualComponentNameToPackageName )+import Distribution.PackageDescription+         ( BuildType(..), RepoKind(..), LibraryName(..) )+import Distribution.System ( Platform )+import Distribution.ReadE+         ( ReadE(..), succeedReadE, parsecToReadE )+import qualified Distribution.Compat.CharParsing as P+import Distribution.Verbosity+         ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )+import Distribution.Simple.Utils+         ( wrapText )+import Distribution.Client.GlobalFlags+         ( GlobalFlags(..), defaultGlobalFlags+         , RepoContext(..), withRepoContext+         )+import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)+import Distribution.FieldGrammar.Newtypes (SpecVersion (..))++import Data.List+         ( deleteFirstsBy )+import System.FilePath+         ( (</>) )++globalCommand :: [Command action] -> CommandUI GlobalFlags+globalCommand commands = CommandUI {+    commandName         = "",+    commandSynopsis     =+         "Command line interface to the Haskell Cabal infrastructure.",+    commandUsage        = \pname ->+         "See http://www.haskell.org/cabal/ for more information.\n"+      ++ "\n"+      ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",+    commandDescription  = Just $ \pname ->+      let+        commands' = commands ++ [commandAddAction helpCommandUI undefined]+        cmdDescs = getNormalCommandDescriptions commands'+        -- if new commands are added, we want them to appear even if they+        -- are not included in the custom listing below. Thus, we calculate+        -- the `otherCmds` list and append it under the `other` category.+        -- Alternatively, a new testcase could be added that ensures that+        -- the set of commands listed here is equal to the set of commands+        -- that are actually available.+        otherCmds = deleteFirstsBy (==) (map fst cmdDescs)+          [ "help"+          , "update"+          , "install"+          , "fetch"+          , "list"+          , "info"+          , "user-config"+          , "get"+          , "init"+          , "configure"+          , "build"+          , "clean"+          , "run"+          , "repl"+          , "test"+          , "bench"+          , "check"+          , "sdist"+          , "upload"+          , "report"+          , "freeze"+          , "gen-bounds"+          , "outdated"+          , "haddock"+          , "hscolour"+          , "exec"+          , "new-build"+          , "new-configure"+          , "new-repl"+          , "new-freeze"+          , "new-run"+          , "new-test"+          , "new-bench"+          , "new-haddock"+          , "new-exec"+          , "new-update"+          , "new-install"+          , "new-clean"+          , "new-sdist"+          , "list-bin"+          -- v1 commands, stateful style+          , "v1-build"+          , "v1-configure"+          , "v1-repl"+          , "v1-freeze"+          , "v1-run"+          , "v1-test"+          , "v1-bench"+          , "v1-haddock"+          , "v1-exec"+          , "v1-update"+          , "v1-install"+          , "v1-clean"+          , "v1-sdist"+          , "v1-doctest"+          , "v1-copy"+          , "v1-register"+          , "v1-reconfigure"+          -- v2 commands, nix-style+          , "v2-build"+          , "v2-configure"+          , "v2-repl"+          , "v2-freeze"+          , "v2-run"+          , "v2-test"+          , "v2-bench"+          , "v2-haddock"+          , "v2-exec"+          , "v2-update"+          , "v2-install"+          , "v2-clean"+          , "v2-sdist"+          ]+        maxlen    = maximum $ [length name | (name, _) <- cmdDescs]+        align str = str ++ replicate (maxlen - length str) ' '+        startGroup n = " ["++n++"]"+        par          = ""+        addCmd n     = case lookup n cmdDescs of+                         Nothing -> ""+                         Just d -> "  " ++ align n ++ "    " ++ d+      in+         "Commands:\n"+      ++ unlines (+        [ startGroup "global"+        , addCmd "update"+        , addCmd "install"+        , par+        , addCmd "help"+        , addCmd "info"+        , addCmd "list"+        , addCmd "fetch"+        , addCmd "user-config"+        , par+        , startGroup "package"+        , addCmd "get"+        , addCmd "init"+        , par+        , addCmd "configure"+        , addCmd "build"+        , addCmd "clean"+        , par+        , addCmd "run"+        , addCmd "repl"+        , addCmd "test"+        , addCmd "bench"+        , par+        , addCmd "check"+        , addCmd "sdist"+        , addCmd "upload"+        , addCmd "report"+        , par+        , addCmd "freeze"+        , addCmd "gen-bounds"+        , addCmd "outdated"+        , addCmd "haddock"+        , addCmd "hscolour"+        , addCmd "exec"+        , addCmd "list-bin"+        , par+        , startGroup "new-style projects (forwards-compatible aliases)"+        , addCmd "v2-build"+        , addCmd "v2-configure"+        , addCmd "v2-repl"+        , addCmd "v2-run"+        , addCmd "v2-test"+        , addCmd "v2-bench"+        , addCmd "v2-freeze"+        , addCmd "v2-haddock"+        , addCmd "v2-exec"+        , addCmd "v2-update"+        , addCmd "v2-install"+        , addCmd "v2-clean"+        , addCmd "v2-sdist"+        , par+        , startGroup "legacy command aliases"+        , addCmd "v1-build"+        , addCmd "v1-configure"+        , addCmd "v1-repl"+        , addCmd "v1-run"+        , addCmd "v1-test"+        , addCmd "v1-bench"+        , addCmd "v1-freeze"+        , addCmd "v1-haddock"+        , addCmd "v1-exec"+        , addCmd "v1-update"+        , addCmd "v1-install"+        , addCmd "v1-clean"+        , addCmd "v1-sdist"+        , addCmd "v1-doctest"+        , addCmd "v1-copy"+        , addCmd "v1-register"+        , addCmd "v1-reconfigure"+        ] ++ if null otherCmds then [] else par+                                           :startGroup "other"+                                           :[addCmd n | n <- otherCmds])+      ++ "\n"+      ++ "For more information about a command use:\n"+      ++ "   " ++ pname ++ " COMMAND --help\n"+      ++ "or " ++ pname ++ " help COMMAND\n"+      ++ "\n"+      ++ "To install Cabal packages from hackage use:\n"+      ++ "  " ++ pname ++ " install foo [--dry-run]\n"+      ++ "\n"+      ++ "Occasionally you need to update the list of available packages:\n"+      ++ "  " ++ pname ++ " update\n",+    commandNotes = Nothing,+    commandDefaultFlags = mempty,+    commandOptions = args+  }+  where+    args :: ShowOrParseArgs -> [OptionField GlobalFlags]+    args ShowArgs  = argsShown+    args ParseArgs = argsShown ++ argsNotShown++    -- arguments we want to show in the help+    argsShown :: [OptionField GlobalFlags]+    argsShown = [+       option ['V'] ["version"]+         "Print version information"+         globalVersion (\v flags -> flags { globalVersion = v })+         trueArg++      ,option [] ["numeric-version"]+         "Print just the version number"+         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })+         trueArg++      ,option [] ["config-file"]+         "Set an alternate location for the config file"+         globalConfigFile (\v flags -> flags { globalConfigFile = v })+         (reqArgFlag "FILE")++      ,option [] ["default-user-config"]+         "Set a location for a cabal.config file for projects without their own cabal.config freeze file."+         globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})+         (reqArgFlag "FILE")++      ,option [] ["ignore-expiry"]+         "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"+         globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })+         trueArg++      ,option [] ["http-transport"]+         "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"+         globalHttpTransport (\v flags -> flags { globalHttpTransport = v })+         (reqArgFlag "HttpTransport")+      ,option [] ["nix"]+         "Nix integration: run commands through nix-shell if a 'shell.nix' file exists"+         globalNix (\v flags -> flags { globalNix = v })+         (boolOpt [] [])++      ]++    -- arguments we don't want shown in the help+    argsNotShown :: [OptionField GlobalFlags]+    argsNotShown = [+       option [] ["remote-repo"]+         "The name and url for a remote repository"+         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })+         (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList))++      ,option [] ["local-no-index-repo"]+         "The name and a path for a local no-index repository"+         globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v })+         (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList))++      ,option [] ["remote-repo-cache"]+         "The location where downloads from all remote repos are cached"+         globalCacheDir (\v flags -> flags { globalCacheDir = v })+         (reqArgFlag "DIR")++      ,option [] ["logs-dir", "logsdir"]+         "The location to put log files"+         globalLogsDir (\v flags -> flags { globalLogsDir = v })+         (reqArgFlag "DIR")++      ,option [] ["world-file"]+         "The location of the world file"+         globalWorldFile (\v flags -> flags { globalWorldFile = v })+         (reqArgFlag "FILE")++      ,option [] ["store-dir", "storedir"]+         "The location of the nix-local-build store"+         globalStoreDir (\v flags -> flags { globalStoreDir = v })+         (reqArgFlag "DIR")++      , option [] ["active-repositories"]+         "The active package repositories"+         globalActiveRepos (\v flags ->  flags { globalActiveRepos = v })+         (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)+                                        (toFlag `fmap` parsec))+                         (map prettyShow . flagToList))+      ]++-- ------------------------------------------------------------+-- * Config flags+-- ------------------------------------------------------------++configureCommand :: CommandUI ConfigFlags+configureCommand = c+  { commandName         = "configure"+  , commandDefaultFlags = mempty+  , commandDescription  = Just $ \_ -> wrapText $+         "Configure how the package is built by setting "+      ++ "package (and other) flags.\n"+      ++ "\n"+      ++ "The configuration affects several other commands, "+      ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n"+  , commandUsage        = \pname ->+    "Usage: " ++ pname ++ " v1-configure [FLAGS]\n"+  , commandNotes = Just $ \pname ->+    (Cabal.programFlagsDescription defaultProgramDb ++ "\n")+      ++ "Examples:\n"+      ++ "  " ++ pname ++ " v1-configure\n"+      ++ "    Configure with defaults;\n"+      ++ "  " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n"+      ++ "    Configure building package including tests,\n"+      ++ "    with some package-specific flag.\n"+  }+ where+  c = Cabal.configureCommand defaultProgramDb++configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]+configureOptions = commandOptions configureCommand++-- | Given some 'ConfigFlags' for the version of Cabal that+-- cabal-install was built with, and a target older 'Version' of+-- Cabal that we want to pass these flags to, convert the+-- flags into a form that will be accepted by the older+-- Setup script.  Generally speaking, this just means filtering+-- out flags that the old Cabal library doesn't understand, but+-- in some cases it may also mean "emulating" a feature using+-- some more legacy flags.+filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags+filterConfigureFlags flags cabalLibVersion+  -- NB: we expect the latest version to be the most common case,+  -- so test it first.+  | cabalLibVersion >= mkVersion [2,5,0]  = flags_latest+  -- The naming convention is that flags_version gives flags with+  -- all flags *introduced* in version eliminated.+  -- It is NOT the latest version of Cabal library that+  -- these flags work for; version of introduction is a more+  -- natural metric.+  | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10+  | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0+  | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0+  | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0+  | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0+  | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1+  | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2+  | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1+  | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0+  | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1+  | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0+  | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0+  | cabalLibVersion < mkVersion [2,1,0]  = flags_2_1_0+  | cabalLibVersion < mkVersion [2,5,0]  = flags_2_5_0+  | otherwise = error "the impossible just happened" -- see first guard+  where+    flags_latest = flags        {+      -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.+      -- Note: this is not in the wrong place. configConstraints gets+      -- repopulated in flags_1_19_1 but it needs to be set to empty for+      -- newer versions first.+      configConstraints = []+      }++    flags_2_5_0 = flags_latest {+      -- Cabal < 2.5 does not understand --dependency=pkg:component=cid+      -- (public sublibraries), so we convert it to the legacy+      -- --dependency=pkg_or_internal_compoent=cid+        configDependencies =+          let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) =+                Just $ GivenComponent+                       (unqualComponentNameToPackageName cn)+                       LMainLibName+                       cid+              convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =+                Just $ GivenComponent pn LMainLibName cid+          in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags+        -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.+      , configAllowDependingOnPrivateLibs = NoFlag+        -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.+      , configFullyStaticExe = NoFlag+      }++    flags_2_1_0 = flags_2_5_0 {+      -- Cabal < 2.1 doesn't know about -v +timestamp modifier+        configVerbosity   = fmap verboseNoTimestamp (configVerbosity flags_latest)+      -- Cabal < 2.1 doesn't know about --<enable|disable>-static+      , configStaticLib   = NoFlag+      , configSplitSections = NoFlag+      }++    flags_1_25_0 = flags_2_1_0 {+      -- Cabal < 1.25.0 doesn't know about --dynlibdir.+      configInstallDirs = configInstallDirs_1_25_0,+      -- Cabal < 1.25 doesn't have extended verbosity syntax+      configVerbosity   = fmap verboseNoFlags (configVerbosity flags_2_1_0),+      -- Cabal < 1.25 doesn't support --deterministic+      configDeterministic = mempty+      }+    configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in+        dirs { dynlibdir = NoFlag+             , libexecsubdir = NoFlag+             , libexecdir = maybeToFlag $+                 combinePathTemplate <$> flagToMaybe (libexecdir dirs)+                                     <*> flagToMaybe (libexecsubdir dirs)+             }+    -- Cabal < 1.23 doesn't know about '--profiling-detail'.+    -- Cabal < 1.23 has a hacked up version of 'enable-profiling'+    -- which we shouldn't use.+    (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags+    flags_1_23_0 = flags_1_25_0 { configProfDetail    = NoFlag+                                , configProfLibDetail = NoFlag+                                , configIPID          = NoFlag+                                , configProf          = NoFlag+                                , configProfExe       = Flag tryExeProfiling+                                , configProfLib       = Flag tryLibProfiling+                                }++    -- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d)+    -- due to temporary amnesia of the --*-executable-profiling flags+    flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag+                                , configProfExe   = NoFlag+                                }++    -- Cabal < 1.22 doesn't know about '--disable-debug-info'.+    flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag }++    -- Cabal < 1.21.1 doesn't know about 'disable-relocatable'+    -- Cabal < 1.21.1 doesn't know about 'enable-profiling'+    -- (but we already dealt with it in flags_1_23_0)+    flags_1_21_1 =+      flags_1_22_0 { configRelocatable = NoFlag+                   , configCoverage = NoFlag+                   , configLibCoverage = configCoverage flags+                   }+    -- Cabal < 1.19.2 doesn't know about '--exact-configuration' and+    -- '--enable-library-stripping'.+    flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag+                                , configStripLibs = NoFlag }+    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.+    flags_1_19_1 = flags_1_19_2 { configDependencies = []+                                , configConstraints  = configConstraints flags }+    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.+    flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList []+                                , configInstallDirs = configInstallDirs_1_18_0}+    configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag }+    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.+    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }+    -- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'+    -- and '--enable/disable-library-coverage'.+    flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag+                                , configDynExe      = NoFlag }+    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.+    flags_1_10_0 = flags_1_12_0 { configTests       = NoFlag }+    -- Cabal < 1.3.10 does not grok the '--constraints' flag.+    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }++-- | Get the package database settings from 'ConfigFlags', accounting for+-- @--package-db@ and @--user@ flags.+configPackageDB' :: ConfigFlags -> PackageDBStack+configPackageDB' cfg =+    interpretPackageDbFlags userInstall (configPackageDBs cfg)+  where+    userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg)++-- | Configure the compiler, but reduce verbosity during this step.+configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb)+configCompilerAux' configFlags =+  configCompilerAuxEx configFlags+    --FIXME: make configCompilerAux use a sensible verbosity+    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }++-- ------------------------------------------------------------+-- * Config extra flags+-- ------------------------------------------------------------++-- | cabal configure takes some extra flags beyond runghc Setup configure+--+data ConfigExFlags = ConfigExFlags {+    configCabalVersion  :: Flag Version,+    configExConstraints :: [(UserConstraint, ConstraintSource)],+    configPreferences   :: [PackageVersionConstraint],+    configSolver        :: Flag PreSolver,+    configAllowNewer    :: Maybe AllowNewer,+    configAllowOlder    :: Maybe AllowOlder,+    configWriteGhcEnvironmentFilesPolicy+      :: Flag WriteGhcEnvironmentFilesPolicy+  }+  deriving (Eq, Show, Generic)++defaultConfigExFlags :: ConfigExFlags+defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver }++configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)+configureExCommand = configureCommand {+    commandDefaultFlags = (mempty, defaultConfigExFlags),+    commandOptions      = \showOrParseArgs ->+         liftOptions fst setFst+         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])+                  . optionName) $ configureOptions  showOrParseArgs)+      ++ liftOptions snd setSnd+         (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++configureExOptions :: ShowOrParseArgs+                   -> ConstraintSource+                   -> [OptionField ConfigExFlags]+configureExOptions _showOrParseArgs src =+  [ option [] ["cabal-lib-version"]+      ("Select which version of the Cabal lib to use to build packages "+      ++ "(useful for testing).")+      configCabalVersion (\v flags -> flags { configCabalVersion = v })+      (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++)+                                    (fmap toFlag parsec))+                        (map prettyShow. flagToList))+  , option [] ["constraint"]+      "Specify constraints on a package (version, installed/source, flags)"+      configExConstraints (\v flags -> flags { configExConstraints = v })+      (reqArg "CONSTRAINT"+              ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)+              (map $ prettyShow . fst))++  , option [] ["preference"]+      "Specify preferences (soft constraints) on the version of a package"+      configPreferences (\v flags -> flags { configPreferences = v })+      (reqArg "CONSTRAINT"+              (parsecToReadE (const "dependency expected")+                          (fmap (\x -> [x]) parsec))+              (map prettyShow))++  , optionSolver configSolver (\v flags -> flags { configSolver = v })++  , option [] ["allow-older"]+    ("Ignore lower bounds in all dependencies or DEPS")+    (fmap unAllowOlder . configAllowOlder)+    (\v flags -> flags { configAllowOlder = fmap AllowOlder v})+    (optArg "DEPS"+     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (Just RelaxDepsAll) relaxDepsPrinter)++  , option [] ["allow-newer"]+    ("Ignore upper bounds in all dependencies or DEPS")+    (fmap unAllowNewer . configAllowNewer)+    (\v flags -> flags { configAllowNewer = fmap AllowNewer v})+    (optArg "DEPS"+     (parsecToReadE ("Cannot parse the list of packages: " ++) relaxDepsParser)+     (Just RelaxDepsAll) relaxDepsPrinter)++  , option [] ["write-ghc-environment-files"]+    ("Whether to create a .ghc.environment file after a successful build"+      ++ " (v2-build only)")+    configWriteGhcEnvironmentFilesPolicy+    (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v})+    (reqArg "always|never|ghc8.4.4+"+     writeGhcEnvironmentFilesPolicyParser+     writeGhcEnvironmentFilesPolicyPrinter)+  ]+++writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy)+writeGhcEnvironmentFilesPolicyParser = ReadE $ \case+  "always"    -> Right $ Flag AlwaysWriteGhcEnvironmentFiles+  "never"     -> Right $ Flag NeverWriteGhcEnvironmentFiles+  "ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer+  policy      -> Left  $ "Cannot parse the GHC environment file write policy '"+                 <> policy <> "'"++writeGhcEnvironmentFilesPolicyPrinter+  :: Flag WriteGhcEnvironmentFilesPolicy -> [String]+writeGhcEnvironmentFilesPolicyPrinter = \case+  (Flag AlwaysWriteGhcEnvironmentFiles)                -> ["always"]+  (Flag NeverWriteGhcEnvironmentFiles)                 -> ["never"]+  (Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"]+  NoFlag                                               -> []+++relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps)+relaxDepsParser =+  (Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',')++relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]+relaxDepsPrinter Nothing                     = []+relaxDepsPrinter (Just RelaxDepsAll)         = [Nothing]+relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs+++instance Monoid ConfigExFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ConfigExFlags where+  (<>) = gmappend++reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags)+reconfigureCommand+  = configureExCommand+    { commandName         = "reconfigure"+    , commandSynopsis     = "Reconfigure the package if necessary."+    , commandDescription  = Just $ \pname -> wrapText $+         "Run `configure` with the most recently used flags, or append FLAGS "+         ++ "to the most recently used configuration. "+         ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. "+         ++ "If the package has never been configured, the default flags are "+         ++ "used."+    , commandNotes        = Just $ \pname ->+        "Examples:\n"+        ++ "  " ++ pname ++ " v1-reconfigure\n"+        ++ "    Configure with the most recently used flags.\n"+        ++ "  " ++ pname ++ " v1-reconfigure -w PATH\n"+        ++ "    Reconfigure with the most recently used flags,\n"+        ++ "    but use the compiler at PATH.\n\n"+    , commandUsage        = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ]+    , commandDefaultFlags = mempty+    }++-- ------------------------------------------------------------+-- * Build flags+-- ------------------------------------------------------------++buildCommand :: CommandUI BuildFlags+buildCommand = parent {+    commandName = "build",+    commandDescription  = Just $ \_ -> wrapText $+      "Components encompass executables, tests, and benchmarks.\n"+        ++ "\n"+        ++ "Affected by configuration options, see `v1-configure`.\n",+    commandDefaultFlags = commandDefaultFlags parent,+    commandUsage        = usageAlternatives "v1-build" $+      [ "[FLAGS]", "COMPONENTS [FLAGS]" ],+    commandOptions      = commandOptions parent+    , commandNotes      = Just $ \pname ->+      "Examples:\n"+        ++ "  " ++ pname ++ " v1-build           "+        ++ "    All the components in the package\n"+        ++ "  " ++ pname ++ " v1-build foo       "+        ++ "    A component (i.e. lib, exe, test suite)\n\n"+        ++ Cabal.programFlagsDescription defaultProgramDb+  }+  where+    parent = Cabal.buildCommand defaultProgramDb++-- ------------------------------------------------------------+-- * Test flags+-- ------------------------------------------------------------++-- | Given some 'TestFlags' for the version of Cabal that+-- cabal-install was built with, and a target older 'Version' of+-- Cabal that we want to pass these flags to, convert the+-- flags into a form that will be accepted by the older+-- Setup script.  Generally speaking, this just means filtering+-- out flags that the old Cabal library doesn't understand, but+-- in some cases it may also mean "emulating" a feature using+-- some more legacy flags.+filterTestFlags :: TestFlags -> Version -> TestFlags+filterTestFlags flags cabalLibVersion+  -- NB: we expect the latest version to be the most common case,+  -- so test it first.+  | cabalLibVersion >= mkVersion [3,0,0] = flags_latest+  -- The naming convention is that flags_version gives flags with+  -- all flags *introduced* in version eliminated.+  -- It is NOT the latest version of Cabal library that+  -- these flags work for; version of introduction is a more+  -- natural metric.+  | cabalLibVersion <  mkVersion [3,0,0] = flags_3_0_0+  | otherwise = error "the impossible just happened" -- see first guard+  where+    flags_latest = flags+    flags_3_0_0  = flags_latest {+      -- Cabal < 3.0 doesn't know about --test-wrapper+      Cabal.testWrapper = NoFlag+      }++-- ------------------------------------------------------------+-- * Repl command+-- ------------------------------------------------------------++replCommand :: CommandUI ReplFlags+replCommand = parent {+    commandName = "repl",+    commandDescription  = Just $ \pname -> wrapText $+         "If the current directory contains no package, ignores COMPONENT "+      ++ "parameters and opens an interactive interpreter session;\n"+      ++ "\n"+      ++ "Otherwise, (re)configures with the given or default flags, and "+      ++ "loads the interpreter with the relevant modules. For executables, "+      ++ "tests and benchmarks, loads the main module (and its "+      ++ "dependencies); for libraries all exposed/other modules.\n"+      ++ "\n"+      ++ "The default component is the library itself, or the executable "+      ++ "if that is the only component.\n"+      ++ "\n"+      ++ "Support for loading specific modules is planned but not "+      ++ "implemented yet. For certain scenarios, `" ++ pname+      ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will "+      ++ "not (re)configure and you will have to specify the location of "+      ++ "other modules, if required.\n",+    commandUsage =  \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n",+    commandDefaultFlags = commandDefaultFlags parent,+    commandOptions      = commandOptions parent,+    commandNotes        = Just $ \pname ->+      "Examples:\n"+    ++ "  " ++ pname ++ " v1-repl           "+    ++ "    The first component in the package\n"+    ++ "  " ++ pname ++ " v1-repl foo       "+    ++ "    A named component (i.e. lib, exe, test suite)\n"+    ++ "  " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\""+    ++ "  Specifying flags for interpreter\n"+  }+  where+    parent = Cabal.replCommand defaultProgramDb++-- ------------------------------------------------------------+-- * Test command+-- ------------------------------------------------------------++testCommand :: CommandUI (BuildFlags, TestFlags)+testCommand = parent {+  commandName = "test",+  commandDescription  = Just $ \pname -> wrapText $+         "If necessary (re)configures with `--enable-tests` flag and builds"+      ++ " the test suite.\n"+      ++ "\n"+      ++ "Remember that the tests' dependencies must be installed if there"+      ++ " are additional ones; e.g. with `" ++ pname+      ++ " v1-install --only-dependencies --enable-tests`.\n"+      ++ "\n"+      ++ "By defining UserHooks in a custom Setup.hs, the package can"+      ++ " define actions to be executed before and after running tests.\n",+  commandUsage = usageAlternatives "v1-test"+      [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ],+  commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),+  commandOptions      =+    \showOrParseArgs -> liftOptions get1 set1+                        (Cabal.buildOptions progDb showOrParseArgs)+                        +++                        liftOptions get2 set2+                        (commandOptions parent showOrParseArgs)+  }+  where+    get1 (a,_) = a; set1 a (_,b) = (a,b)+    get2 (_,b) = b; set2 b (a,_) = (a,b)++    parent = Cabal.testCommand+    progDb = defaultProgramDb++-- ------------------------------------------------------------+-- * Bench command+-- ------------------------------------------------------------++benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags)+benchmarkCommand = parent {+  commandName = "bench",+  commandUsage = usageAlternatives "v1-bench"+      [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ],+  commandDescription  = Just $ \pname -> wrapText $+         "If necessary (re)configures with `--enable-benchmarks` flag and"+      ++ " builds the benchmarks.\n"+      ++ "\n"+      ++ "Remember that the benchmarks' dependencies must be installed if"+      ++ " there are additional ones; e.g. with `" ++ pname+      ++ " v1-install --only-dependencies --enable-benchmarks`.\n"+      ++ "\n"+      ++ "By defining UserHooks in a custom Setup.hs, the package can"+      ++ " define actions to be executed before and after running"+      ++ " benchmarks.\n",+  commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),+  commandOptions      =+    \showOrParseArgs -> liftOptions get1 set1+                        (Cabal.buildOptions progDb showOrParseArgs)+                        +++                        liftOptions get2 set2+                        (commandOptions parent showOrParseArgs)+  }+  where+    get1 (a,_) = a; set1 a (_,b) = (a,b)+    get2 (_,b) = b; set2 b (a,_) = (a,b)++    parent = Cabal.benchmarkCommand+    progDb = defaultProgramDb++-- ------------------------------------------------------------+-- * Fetch command+-- ------------------------------------------------------------++data FetchFlags = FetchFlags {+--    fetchOutput    :: Flag FilePath,+      fetchDeps      :: Flag Bool,+      fetchDryRun    :: Flag Bool,+      fetchSolver           :: Flag PreSolver,+      fetchMaxBackjumps     :: Flag Int,+      fetchReorderGoals     :: Flag ReorderGoals,+      fetchCountConflicts   :: Flag CountConflicts,+      fetchFineGrainedConflicts :: Flag FineGrainedConflicts,+      fetchMinimizeConflictSet :: Flag MinimizeConflictSet,+      fetchIndependentGoals :: Flag IndependentGoals,+      fetchShadowPkgs       :: Flag ShadowPkgs,+      fetchStrongFlags      :: Flag StrongFlags,+      fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls,+      fetchOnlyConstrained  :: Flag OnlyConstrained,+      fetchTests            :: Flag Bool,+      fetchBenchmarks       :: Flag Bool,+      fetchVerbosity :: Flag Verbosity+    }++defaultFetchFlags :: FetchFlags+defaultFetchFlags = FetchFlags {+--  fetchOutput    = mempty,+    fetchDeps      = toFlag True,+    fetchDryRun    = toFlag False,+    fetchSolver           = Flag defaultSolver,+    fetchMaxBackjumps     = Flag defaultMaxBackjumps,+    fetchReorderGoals     = Flag (ReorderGoals False),+    fetchCountConflicts   = Flag (CountConflicts True),+    fetchFineGrainedConflicts = Flag (FineGrainedConflicts True),+    fetchMinimizeConflictSet = Flag (MinimizeConflictSet False),+    fetchIndependentGoals = Flag (IndependentGoals False),+    fetchShadowPkgs       = Flag (ShadowPkgs False),+    fetchStrongFlags      = Flag (StrongFlags False),+    fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False),+    fetchOnlyConstrained  = Flag OnlyConstrainedNone,+    fetchTests            = toFlag False,+    fetchBenchmarks       = toFlag False,+    fetchVerbosity = toFlag normal+   }++fetchCommand :: CommandUI FetchFlags+fetchCommand = CommandUI {+    commandName         = "fetch",+    commandSynopsis     = "Downloads packages for later installation.",+    commandUsage        = usageAlternatives "fetch" [ "[FLAGS] PACKAGES"+                                                    ],+    commandDescription  = Just $ \_ ->+          "Note that it currently is not possible to fetch the dependencies for a\n"+       ++ "package in the current directory.\n",+    commandNotes        = Nothing,+    commandDefaultFlags = defaultFetchFlags,+    commandOptions      = \ showOrParseArgs -> [+         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })++--     , option "o" ["output"]+--         "Put the package(s) somewhere specific rather than the usual cache."+--         fetchOutput (\v flags -> flags { fetchOutput = v })+--         (reqArgFlag "PATH")++       , option [] ["dependencies", "deps"]+           "Resolve and fetch dependencies (default)"+           fetchDeps (\v flags -> flags { fetchDeps = v })+           trueArg++       , option [] ["no-dependencies", "no-deps"]+           "Ignore dependencies"+           fetchDeps (\v flags -> flags { fetchDeps = v })+           falseArg++       , option [] ["dry-run"]+           "Do not install anything, only print what would be installed."+           fetchDryRun (\v flags -> flags { fetchDryRun = v })+           trueArg++      , option "" ["tests"]+         "dependency checking and compilation for test suites listed in the package description file."+         fetchTests (\v flags -> flags { fetchTests = v })+         (boolOpt [] [])++      , option "" ["benchmarks"]+         "dependency checking and compilation for benchmarks listed in the package description file."+         fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v })+         (boolOpt [] [])++       ] ++++       optionSolver      fetchSolver           (\v flags -> flags { fetchSolver           = v }) :+       optionSolverFlags showOrParseArgs+                         fetchMaxBackjumps     (\v flags -> flags { fetchMaxBackjumps     = v })+                         fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })+                         fetchCountConflicts   (\v flags -> flags { fetchCountConflicts   = v })+                         fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v })+                         fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v })+                         fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })+                         fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })+                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })+                         fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v })+                         fetchOnlyConstrained  (\v flags -> flags { fetchOnlyConstrained  = v })++  }++-- ------------------------------------------------------------+-- * Freeze command+-- ------------------------------------------------------------++data FreezeFlags = FreezeFlags {+      freezeDryRun           :: Flag Bool,+      freezeTests            :: Flag Bool,+      freezeBenchmarks       :: Flag Bool,+      freezeSolver           :: Flag PreSolver,+      freezeMaxBackjumps     :: Flag Int,+      freezeReorderGoals     :: Flag ReorderGoals,+      freezeCountConflicts   :: Flag CountConflicts,+      freezeFineGrainedConflicts :: Flag FineGrainedConflicts,+      freezeMinimizeConflictSet :: Flag MinimizeConflictSet,+      freezeIndependentGoals :: Flag IndependentGoals,+      freezeShadowPkgs       :: Flag ShadowPkgs,+      freezeStrongFlags      :: Flag StrongFlags,+      freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls,+      freezeOnlyConstrained  :: Flag OnlyConstrained,+      freezeVerbosity        :: Flag Verbosity+    }++defaultFreezeFlags :: FreezeFlags+defaultFreezeFlags = FreezeFlags {+    freezeDryRun           = toFlag False,+    freezeTests            = toFlag False,+    freezeBenchmarks       = toFlag False,+    freezeSolver           = Flag defaultSolver,+    freezeMaxBackjumps     = Flag defaultMaxBackjumps,+    freezeReorderGoals     = Flag (ReorderGoals False),+    freezeCountConflicts   = Flag (CountConflicts True),+    freezeFineGrainedConflicts = Flag (FineGrainedConflicts True),+    freezeMinimizeConflictSet = Flag (MinimizeConflictSet False),+    freezeIndependentGoals = Flag (IndependentGoals False),+    freezeShadowPkgs       = Flag (ShadowPkgs False),+    freezeStrongFlags      = Flag (StrongFlags False),+    freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False),+    freezeOnlyConstrained  = Flag OnlyConstrainedNone,+    freezeVerbosity        = toFlag normal+   }++freezeCommand :: CommandUI FreezeFlags+freezeCommand = CommandUI {+    commandName         = "freeze",+    commandSynopsis     = "Freeze dependencies.",+    commandDescription  = Just $ \_ -> wrapText $+         "Calculates a valid set of dependencies and their exact versions. "+      ++ "If successful, saves the result to the file `cabal.config`.\n"+      ++ "\n"+      ++ "The package versions specified in `cabal.config` will be used for "+      ++ "any future installs.\n"+      ++ "\n"+      ++ "An existing `cabal.config` is ignored and overwritten.\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "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++       , option [] ["tests"]+           ("freezing of the dependencies of any tests suites "+            ++ "in the package description file.")+           freezeTests (\v flags -> flags { freezeTests = v })+           (boolOpt [] [])++       , option [] ["benchmarks"]+           ("freezing of the dependencies of any benchmarks suites "+            ++ "in the package description file.")+           freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v })+           (boolOpt [] [])++       ] ++++       optionSolver+         freezeSolver           (\v flags -> flags { freezeSolver           = v }):+       optionSolverFlags showOrParseArgs+                         freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })+                         freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })+                         freezeCountConflicts   (\v flags -> flags { freezeCountConflicts   = v })+                         freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v })+                         freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v })+                         freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })+                         freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })+                         freezeStrongFlags      (\v flags -> flags { freezeStrongFlags      = v })+                         freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v })+                         freezeOnlyConstrained  (\v flags -> flags { freezeOnlyConstrained  = v })++  }++-- ------------------------------------------------------------+-- * 'gen-bounds' command+-- ------------------------------------------------------------++genBoundsCommand :: CommandUI FreezeFlags+genBoundsCommand = CommandUI {+    commandName         = "gen-bounds",+    commandSynopsis     = "Generate dependency bounds.",+    commandDescription  = Just $ \_ -> wrapText $+         "Generates bounds for all dependencies that do not currently have them. "+      ++ "Generated bounds are printed to stdout.  "+      ++ "You can then paste them into your .cabal file.\n"+      ++ "\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "gen-bounds",+    commandDefaultFlags = defaultFreezeFlags,+    commandOptions      = \ _ -> [+     optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })+     ]+  }++-- ------------------------------------------------------------+-- * 'outdated' command+-- ------------------------------------------------------------++data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone+                             | IgnoreMajorVersionBumpsAll+                             | IgnoreMajorVersionBumpsSome [PackageName]++instance Monoid IgnoreMajorVersionBumps where+  mempty  = IgnoreMajorVersionBumpsNone+  mappend = (<>)++instance Semigroup IgnoreMajorVersionBumps where+  IgnoreMajorVersionBumpsNone       <> r                               = r+  l@IgnoreMajorVersionBumpsAll      <> _                               = l+  l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone     = l+  (IgnoreMajorVersionBumpsSome   _) <> r@IgnoreMajorVersionBumpsAll    = r+  (IgnoreMajorVersionBumpsSome   a) <> (IgnoreMajorVersionBumpsSome b) =+    IgnoreMajorVersionBumpsSome (a ++ b)++data OutdatedFlags = OutdatedFlags {+  outdatedVerbosity     :: Flag Verbosity,+  outdatedFreezeFile    :: Flag Bool,+  outdatedNewFreezeFile :: Flag Bool,+  outdatedProjectFile   :: Flag FilePath,+  outdatedSimpleOutput  :: Flag Bool,+  outdatedExitCode      :: Flag Bool,+  outdatedQuiet         :: Flag Bool,+  outdatedIgnore        :: [PackageName],+  outdatedMinor         :: Maybe IgnoreMajorVersionBumps+  }++defaultOutdatedFlags :: OutdatedFlags+defaultOutdatedFlags = OutdatedFlags {+  outdatedVerbosity     = toFlag normal,+  outdatedFreezeFile    = mempty,+  outdatedNewFreezeFile = mempty,+  outdatedProjectFile   = mempty,+  outdatedSimpleOutput  = mempty,+  outdatedExitCode      = mempty,+  outdatedQuiet         = mempty,+  outdatedIgnore        = mempty,+  outdatedMinor         = mempty+  }++outdatedCommand :: CommandUI OutdatedFlags+outdatedCommand = CommandUI {+  commandName = "outdated",+  commandSynopsis = "Check for outdated dependencies",+  commandDescription  = Just $ \_ -> wrapText $+    "Checks for outdated dependencies in the package description file "+    ++ "or freeze file",+  commandNotes = Nothing,+  commandUsage = usageFlags "outdated",+  commandDefaultFlags = defaultOutdatedFlags,+  commandOptions      = \ _ -> [+    optionVerbosity outdatedVerbosity+      (\v flags -> flags { outdatedVerbosity = v })++    ,option [] ["freeze-file", "v1-freeze-file"]+     "Act on the freeze file"+     outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v })+     trueArg++    ,option [] ["v2-freeze-file", "new-freeze-file"]+     "Act on the new-style freeze file (default: cabal.project.freeze)"+     outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v })+     trueArg++    ,option [] ["project-file"]+     "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze"+     outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v })+     (reqArgFlag "PROJECTFILE")++    ,option [] ["simple-output"]+     "Only print names of outdated dependencies, one per line"+     outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v })+     trueArg++    ,option [] ["exit-code"]+     "Exit with non-zero when there are outdated dependencies"+     outdatedExitCode (\v flags -> flags { outdatedExitCode = v })+     trueArg++    ,option ['q'] ["quiet"]+     "Don't print any output. Implies '--exit-code' and '-v0'"+     outdatedQuiet (\v flags -> flags { outdatedQuiet = v })+     trueArg++   ,option [] ["ignore"]+    "Packages to ignore"+    outdatedIgnore (\v flags -> flags { outdatedIgnore = v })+    (reqArg "PKGS" pkgNameListParser (map prettyShow))++   ,option [] ["minor"]+    "Ignore major version bumps for these packages"+    outdatedMinor (\v flags -> flags { outdatedMinor = v })+    (optArg "PKGS" ignoreMajorVersionBumpsParser+      (Just IgnoreMajorVersionBumpsAll) ignoreMajorVersionBumpsPrinter)+   ]+  }+  where+    ignoreMajorVersionBumpsPrinter :: (Maybe IgnoreMajorVersionBumps)+                                   -> [Maybe String]+    ignoreMajorVersionBumpsPrinter Nothing = []+    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []+    ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]+    ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =+      map (Just . prettyShow) $ pkgs++    ignoreMajorVersionBumpsParser  =+      (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser++    pkgNameListParser = parsecToReadE+      ("Couldn't parse the list of package names: " ++)+      (fmap toList (P.sepByNonEmpty parsec (P.char ',')))++-- ------------------------------------------------------------+-- * Update command+-- ------------------------------------------------------------++data UpdateFlags+    = UpdateFlags {+        updateVerbosity  :: Flag Verbosity,+        updateIndexState :: Flag TotalIndexState+    } deriving Generic++defaultUpdateFlags :: UpdateFlags+defaultUpdateFlags+    = UpdateFlags {+        updateVerbosity  = toFlag normal,+        updateIndexState = toFlag headTotalIndexState+    }++-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------++cleanCommand :: CommandUI CleanFlags+cleanCommand = Cabal.cleanCommand+  { commandUsage = \pname ->+    "Usage: " ++ pname ++ " v1-clean [FLAGS]\n"+  }++checkCommand  :: CommandUI (Flag Verbosity)+checkCommand = CommandUI {+    commandName         = "check",+    commandSynopsis     = "Check the package for common mistakes.",+    commandDescription  = Just $ \_ -> wrapText $+         "Expects a .cabal package file in the current directory.\n"+      ++ "\n"+      ++ "The checks correspond to the requirements to packages on Hackage. "+      ++ "If no errors and warnings are reported, Hackage will accept this "+      ++ "package.\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "check",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++formatCommand  :: CommandUI (Flag Verbosity)+formatCommand = CommandUI {+    commandName         = "format",+    commandSynopsis     = "Reformat the .cabal file using the standard style.",+    commandDescription  = Nothing,+    commandNotes        = Nothing,+    commandUsage        = usageAlternatives "format" ["[FILE]"],+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }++manpageCommand :: CommandUI ManpageFlags+manpageCommand = CommandUI {+    commandName         = "man",+    commandSynopsis     = "Outputs manpage source.",+    commandDescription  = Just $ \_ ->+      "Output manpage source to STDOUT.\n",+    commandNotes        = Nothing,+    commandUsage        = usageFlags "man",+    commandDefaultFlags = defaultManpageFlags,+    commandOptions      = manpageOptions+  }++runCommand :: CommandUI BuildFlags+runCommand = CommandUI {+    commandName         = "run",+    commandSynopsis     = "Builds and runs an executable.",+    commandDescription  = Just $ \pname -> wrapText $+         "Builds and then runs the specified executable. If no executable is "+      ++ "specified, but the package contains just one executable, that one "+      ++ "is built and executed.\n"+      ++ "\n"+      ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a "+      ++ "test-suite and get its full output.\n",+    commandNotes        = Just $ \pname ->+          "Examples:\n"+       ++ "  " ++ pname ++ " v1-run\n"+       ++ "    Run the only executable in the current package;\n"+       ++ "  " ++ pname ++ " v1-run foo -- --fooflag\n"+       ++ "    Works similar to `./foo --fooflag`.\n",+    commandUsage        = usageAlternatives "v1-run"+        ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],+    commandDefaultFlags = mempty,+    commandOptions      = commandOptions parent+  }+  where+    parent = Cabal.buildCommand defaultProgramDb++-- ------------------------------------------------------------+-- * Report flags+-- ------------------------------------------------------------++data ReportFlags = ReportFlags {+    reportUsername  :: Flag Username,+    reportPassword  :: Flag Password,+    reportVerbosity :: Flag Verbosity+  } deriving Generic++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags {+    reportUsername  = mempty,+    reportPassword  = mempty,+    reportVerbosity = toFlag normal+  }++reportCommand :: CommandUI ReportFlags+reportCommand = CommandUI {+    commandName         = "report",+    commandSynopsis     = "Upload build reports to a remote server.",+    commandDescription  = Nothing,+    commandNotes        = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandUsage        = usageAlternatives "report" ["[FLAGS]"],+    commandDefaultFlags = defaultReportFlags,+    commandOptions      = \_ ->+      [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })++      ,option ['u'] ["username"]+        "Hackage username."+        reportUsername (\v flags -> flags { reportUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        reportPassword (\v flags -> flags { reportPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))+      ]+  }++instance Monoid ReportFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ReportFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Get flags+-- ------------------------------------------------------------++data GetFlags = GetFlags {+    getDestDir          :: Flag FilePath,+    getPristine         :: Flag Bool,+    getIndexState       :: Flag TotalIndexState,+    getActiveRepos      :: Flag ActiveRepos,+    getSourceRepository :: Flag (Maybe RepoKind),+    getVerbosity        :: Flag Verbosity+  } deriving Generic++defaultGetFlags :: GetFlags+defaultGetFlags = GetFlags {+    getDestDir          = mempty,+    getPristine         = mempty,+    getIndexState       = mempty,+    getActiveRepos      = mempty,+    getSourceRepository = mempty,+    getVerbosity        = toFlag normal+   }++getCommand :: CommandUI GetFlags+getCommand = CommandUI {+    commandName         = "get",+    commandSynopsis     = "Download/Extract a package's source code (repository).",+    commandDescription  = Just $ \_ -> wrapText $+          "Creates a local copy of a package's source code. By default it gets "+       ++ "the source\ntarball and unpacks it in a local subdirectory. "+       ++ "Alternatively, with -s it will\nget the code from the source "+       ++ "repository specified by the package.\n",+    commandNotes        = Just $ \pname ->+          "Examples:\n"+       ++ "  " ++ pname ++ " get hlint\n"+       ++ "    Download the latest stable version of hlint;\n"+       ++ "  " ++ pname ++ " get lens --source-repository=head\n"+       ++ "    Download the source repository (i.e. git clone from github).\n",+    commandUsage        = usagePackages "get",+    commandDefaultFlags = defaultGetFlags,+    commandOptions      = \_ -> [+        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })++       ,option "d" ["destdir"]+         "Where to place the package source, defaults to the current directory."+         getDestDir (\v flags -> flags { getDestDir = v })+         (reqArgFlag "PATH")++       ,option "s" ["source-repository"]+         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."+         getSourceRepository (\v flags -> flags { getSourceRepository = v })+        (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository")+                                              (fmap (toFlag . Just) parsec))+                                  (Flag Nothing)+                                  (map (fmap show) . flagToList))++      , option [] ["index-state"]+          ("Use source package index state as it existed at a previous time. " +++           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " +++           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " +++           "This determines which package versions are available as well as " +++           ".cabal file revision is selected (unless --pristine is used).")+          getIndexState (\v flags -> flags { getIndexState = v })+          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " +++                                       "unix-timestamps (e.g. '@1474732068'), " +++                                       "a ISO8601 UTC timestamp " +++                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))++       , option [] ["pristine"]+           ("Unpack the original pristine tarball, rather than updating the "+           ++ ".cabal file with the latest revision from the package archive.")+           getPristine (\v flags -> flags { getPristine = v })+           trueArg+       ]+  }++-- 'cabal unpack' is a deprecated alias for 'cabal get'.+unpackCommand :: CommandUI GetFlags+unpackCommand = getCommand {+  commandName  = "unpack",+  commandUsage = usagePackages "unpack"+  }++instance Monoid GetFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup GetFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * List flags+-- ------------------------------------------------------------++data ListFlags = ListFlags+    { listInstalled       :: Flag Bool+    , listSimpleOutput    :: Flag Bool+    , listCaseInsensitive :: Flag Bool+    , listVerbosity       :: Flag Verbosity+    , listPackageDBs      :: [Maybe PackageDB]+    , listHcPath          :: Flag FilePath+    }+  deriving Generic++defaultListFlags :: ListFlags+defaultListFlags = ListFlags+    { listInstalled       = Flag False+    , listSimpleOutput    = Flag False+    , listCaseInsensitive = Flag True+    , listVerbosity       = toFlag normal+    , listPackageDBs      = []+    , listHcPath          = mempty+    }++listCommand  :: CommandUI ListFlags+listCommand = CommandUI {+    commandName         = "list",+    commandSynopsis     = "List packages matching a search string.",+    commandDescription  = Just $ \_ -> wrapText $+         "List all packages, or all packages matching one of the search"+      ++ " strings.\n"+      ++ "\n"+      ++ "Use the package database specified with --package-db. "+      ++ "If not specified, use the user package database.\n",+    commandNotes        = Just $ \pname ->+         "Examples:\n"+      ++ "  " ++ pname ++ " list pandoc\n"+      ++ "    Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n",+    commandUsage        = usageAlternatives "list" [ "[FLAGS]"+                                                   , "[FLAGS] STRINGS"],+    commandDefaultFlags = defaultListFlags,+    commandOptions      = const listOptions+  }++listOptions :: [OptionField ListFlags]+listOptions =+    [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })++    , option [] ["installed"]+        "Only print installed packages"+        listInstalled (\v flags -> flags { listInstalled = v })+        trueArg++    , option [] ["simple-output"]+        "Print in a easy-to-parse format"+        listSimpleOutput (\v flags -> flags { listSimpleOutput = v })+        trueArg+    , option ['i'] ["ignore-case"]+        "Ignore case destictions"+        listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v })+        (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"]))++    , option "" ["package-db"]+      (   "Append the given package database to the list of package"+       ++ " databases used (to satisfy dependencies and register into)."+       ++ " May be a specific file, 'global' or 'user'. The initial list"+       ++ " is ['global'], ['global', 'user'],"+       ++ " depending on context. Use 'clear' to reset the list to empty."+       ++ " See the user guide for details.")+      listPackageDBs (\v flags -> flags { listPackageDBs = v })+      (reqArg' "DB" readPackageDbList showPackageDbList)++    , option "w" ["with-compiler"]+      "give the path to a particular compiler"+      listHcPath (\v flags -> flags { listHcPath = v })+      (reqArgFlag "PATH")+    ]++listNeedsCompiler :: ListFlags -> Bool+listNeedsCompiler f =+    flagElim False (const True) (listHcPath f)+    || fromFlagOrDefault False (listInstalled f)++instance Monoid ListFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ListFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Info flags+-- ------------------------------------------------------------++data InfoFlags = InfoFlags {+    infoVerbosity  :: Flag Verbosity,+    infoPackageDBs :: [Maybe PackageDB]+  } deriving Generic++defaultInfoFlags :: InfoFlags+defaultInfoFlags = InfoFlags {+    infoVerbosity  = toFlag normal,+    infoPackageDBs = []+  }++infoCommand  :: CommandUI InfoFlags+infoCommand = CommandUI {+    commandName         = "info",+    commandSynopsis     = "Display detailed information about a particular package.",+    commandDescription  = Just $ \_ -> wrapText $+      "Use the package database specified with --package-db. "+      ++ "If not specified, use the user package database.\n",+    commandNotes        = Nothing,+    commandUsage        = usageAlternatives "info" ["[FLAGS] PACKAGES"],+    commandDefaultFlags = defaultInfoFlags,+    commandOptions      = \_ -> [+        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })++        , option "" ["package-db"]+          (   "Append the given package database to the list of package"+           ++ " databases used (to satisfy dependencies and register into)."+           ++ " May be a specific file, 'global' or 'user'. The initial list"+           ++ " is ['global'], ['global', 'user'],"+           ++ " depending on context. Use 'clear' to reset the list to empty."+           ++ " See the user guide for details.")+          infoPackageDBs (\v flags -> flags { infoPackageDBs = v })+          (reqArg' "DB" readPackageDbList showPackageDbList)++        ]+  }++instance Monoid InfoFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup InfoFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Install flags+-- ------------------------------------------------------------++-- | Install takes the same flags as configure along with a few extras.+--+data InstallFlags = InstallFlags {+    installDocumentation    :: Flag Bool,+    installHaddockIndex     :: Flag PathTemplate,+    installDest             :: Flag Cabal.CopyDest,+    installDryRun           :: Flag Bool,+    installOnlyDownload     :: Flag Bool,+    installMaxBackjumps     :: Flag Int,+    installReorderGoals     :: Flag ReorderGoals,+    installCountConflicts   :: Flag CountConflicts,+    installFineGrainedConflicts :: Flag FineGrainedConflicts,+    installMinimizeConflictSet :: Flag MinimizeConflictSet,+    installIndependentGoals :: Flag IndependentGoals,+    installShadowPkgs       :: Flag ShadowPkgs,+    installStrongFlags      :: Flag StrongFlags,+    installAllowBootLibInstalls :: Flag AllowBootLibInstalls,+    installOnlyConstrained  :: Flag OnlyConstrained,+    installReinstall        :: Flag Bool,+    installAvoidReinstalls  :: Flag AvoidReinstalls,+    installOverrideReinstall :: Flag Bool,+    installUpgradeDeps      :: Flag Bool,+    installOnly             :: Flag Bool,+    installOnlyDeps         :: Flag Bool,+    installIndexState       :: Flag TotalIndexState,+    installRootCmd          :: Flag String,+    installSummaryFile      :: NubList PathTemplate,+    installLogFile          :: Flag PathTemplate,+    installBuildReports     :: Flag ReportLevel,+    installReportPlanningFailure :: Flag Bool,+    -- Note: symlink-bindir is no longer used by v2-install and can be removed+    -- when removing v1 commands+    installSymlinkBinDir    :: Flag FilePath,+    installPerComponent     :: Flag Bool,+    installOneShot          :: Flag Bool,+    installNumJobs          :: Flag (Maybe Int),+    installKeepGoing        :: Flag Bool,+    installRunTests         :: Flag Bool,+    installOfflineMode      :: Flag Bool+  }+  deriving (Eq, Show, Generic)++instance Binary InstallFlags++defaultInstallFlags :: InstallFlags+defaultInstallFlags = InstallFlags {+    installDocumentation   = Flag False,+    installHaddockIndex    = Flag docIndexFile,+    installDest            = Flag Cabal.NoCopyDest,+    installDryRun          = Flag False,+    installOnlyDownload    = Flag False,+    installMaxBackjumps    = Flag defaultMaxBackjumps,+    installReorderGoals    = Flag (ReorderGoals False),+    installCountConflicts  = Flag (CountConflicts True),+    installFineGrainedConflicts = Flag (FineGrainedConflicts True),+    installMinimizeConflictSet = Flag (MinimizeConflictSet False),+    installIndependentGoals= Flag (IndependentGoals False),+    installShadowPkgs      = Flag (ShadowPkgs False),+    installStrongFlags     = Flag (StrongFlags False),+    installAllowBootLibInstalls = Flag (AllowBootLibInstalls False),+    installOnlyConstrained = Flag OnlyConstrainedNone,+    installReinstall       = Flag False,+    installAvoidReinstalls = Flag (AvoidReinstalls False),+    installOverrideReinstall = Flag False,+    installUpgradeDeps     = Flag False,+    installOnly            = Flag False,+    installOnlyDeps        = Flag False,+    installIndexState      = mempty,+    installRootCmd         = mempty,+    installSummaryFile     = mempty,+    installLogFile         = mempty,+    installBuildReports    = Flag NoReports,+    installReportPlanningFailure = Flag False,+    installSymlinkBinDir   = mempty,+    installPerComponent    = Flag True,+    installOneShot         = Flag False,+    installNumJobs         = mempty,+    installKeepGoing       = Flag False,+    installRunTests        = mempty,+    installOfflineMode     = Flag False+  }+  where+    docIndexFile = toPathTemplate ("$datadir" </> "doc"+                                   </> "$arch-$os-$compiler" </> "index.html")++defaultMaxBackjumps :: Int+defaultMaxBackjumps = 4000++defaultSolver :: PreSolver+defaultSolver = AlwaysModular++allSolvers :: String+allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver]))++installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+                            , HaddockFlags, TestFlags, BenchmarkFlags+                            )+installCommand = CommandUI {+  commandName         = "install",+  commandSynopsis     = "Install packages.",+  commandUsage        = usageAlternatives "v1-install" [ "[FLAGS]"+                                                    , "[FLAGS] PACKAGES"+                                                    ],+  commandDescription  = Just $ \_ -> wrapText $+        "Installs one or more packages. By default, the installed package"+     ++ " will be registered in the user's package database."+     ++ "\n"+     ++ "If PACKAGES are specified, downloads and installs those packages."+     ++ " Otherwise, install the package in the current directory (and/or its"+     ++ " dependencies) (there must be exactly one .cabal file in the current"+     ++ " directory).\n"+     ++ "\n"+     ++ "The flags to `v1-install` are saved and"+     ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for"+     ++ " `v1-configure` for a list of commands being affected.\n"+     ++ "\n"+     ++ "Installed executables will by default"+     ++ " be put into `~/.cabal/bin/`."+     ++ " If you want installed executable to be available globally, make"+     ++ " sure that the PATH environment variable contains that directory.\n"+     ++ "\n",+  commandNotes        = Just $ \pname ->+        ( case commandNotes+               $ Cabal.configureCommand defaultProgramDb+          of Just desc -> desc pname ++ "\n"+             Nothing   -> ""+        )+     ++ "Examples:\n"+     ++ "  " ++ pname ++ " v1-install                 "+     ++ "    Package in the current directory\n"+     ++ "  " ++ pname ++ " v1-install foo             "+     ++ "    Package from the hackage server\n"+     ++ "  " ++ pname ++ " v1-install foo-1.0         "+     ++ "    Specific version of a package\n"+     ++ "  " ++ pname ++ " v1-install 'foo < 2'       "+     ++ "    Constrained package version\n"+     ++ "  " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"+     ++ "  " ++ (map (const ' ') pname)+                      ++ "                         "+     ++ "    Change installation destination\n",+  commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty),+  commandOptions      = \showOrParseArgs ->+       liftOptions get1 set1+       -- Note: [Hidden Flags]+       -- hide "constraint", "dependency", and+       -- "exact-configuration" from the configure options.+       (filter ((`notElem` ["constraint", "dependency"+                           , "exact-configuration"])+                . optionName) $+                              configureOptions   showOrParseArgs)+    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)+    ++ liftOptions get3 set3+       -- hide "target-package-db" flag from the+       -- install options.+       (filter ((`notElem` ["target-package-db"])+                . optionName) $+                              installOptions     showOrParseArgs)+    ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)+    ++ liftOptions get5 set5 (testOptions        showOrParseArgs)+    ++ liftOptions get6 set6 (benchmarkOptions   showOrParseArgs)+  }+  where+    get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)+    get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f)+    get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f)+    get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f)+    get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f)+    get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f)++haddockCommand :: CommandUI HaddockFlags+haddockCommand = Cabal.haddockCommand+  { commandUsage = usageAlternatives "v1-haddock" $+      [ "[FLAGS]", "COMPONENTS [FLAGS]" ]+  }++filterHaddockArgs :: [String] -> Version -> [String]+filterHaddockArgs args cabalLibVersion+  | cabalLibVersion >= mkVersion [2,3,0] = args_latest+  | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0+  | otherwise = args_latest+  where+    args_latest = args++    -- Cabal < 2.3 doesn't know about per-component haddock+    args_2_3_0 = []++filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags+filterHaddockFlags flags cabalLibVersion+  | cabalLibVersion >= mkVersion [2,3,0] = flags_latest+  | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0+  | otherwise = flags_latest+  where+    flags_latest = flags++    flags_2_3_0 = flags_latest {+      -- Cabal < 2.3 doesn't know about per-component haddock+      haddockArgs = []+      }++haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]+haddockOptions showOrParseArgs+  = [ opt { optionName = "haddock-" ++ name,+            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr+                          | descr <- optionDescr opt] }+    | opt <- commandOptions Cabal.haddockCommand showOrParseArgs+    , let name = optionName opt+    , name `elem` ["hoogle", "html", "html-location"+                  ,"executables", "tests", "benchmarks", "all", "internal", "css"+                  ,"hyperlink-source", "quickjump", "hscolour-css"+                  ,"contents-location", "for-hackage"]+    ]++testOptions :: ShowOrParseArgs -> [OptionField TestFlags]+testOptions showOrParseArgs+  = [ opt { optionName = prefixTest name,+            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr+                          | descr <- optionDescr opt] }+    | opt <- commandOptions Cabal.testCommand showOrParseArgs+    , let name = optionName opt+    , name `elem` ["log", "machine-log", "show-details", "keep-tix-files"+                  ,"fail-when-no-test-suites", "test-options", "test-option"+                  ,"test-wrapper"]+    ]+  where+    prefixTest name | "test-" `isPrefixOf` name = name+                    | otherwise = "test-" ++ name++benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags]+benchmarkOptions showOrParseArgs+  = [ opt { optionName = prefixBenchmark name,+            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr+                          | descr <- optionDescr opt] }+    | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs+    , let name = optionName opt+    , name `elem` ["benchmark-options", "benchmark-option"]+    ]+  where+    prefixBenchmark name | "benchmark-" `isPrefixOf` name = name+                         | otherwise = "benchmark-" ++ name++fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a+fmapOptFlags modify (ReqArg d f p r w)    = ReqArg d (modify f) p r w+fmapOptFlags modify (OptArg d f p r i w)  = OptArg d (modify f) p r i w+fmapOptFlags modify (ChoiceOpt xs)        = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]+fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w++installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]+installOptions showOrParseArgs =+      [ option "" ["documentation"]+          "building of documentation"+          installDocumentation (\v flags -> flags { installDocumentation = v })+          (boolOpt [] [])++      , option [] ["doc-index-file"]+          "A central index of haddock API documentation (template cannot use $pkgid)"+          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate))++      , option [] ["dry-run"]+          "Do not install anything, only print what would be installed."+          installDryRun (\v flags -> flags { installDryRun = v })+          trueArg++      , option [] ["only-download"]+          "Do not build anything, only fetch the packages."+          installOnlyDownload (\v flags -> flags { installOnlyDownload = v })+          trueArg++      , option "" ["target-package-db"]+         "package database to install into. Required when using ${pkgroot} prefix."+         installDest (\v flags -> flags { installDest = v })+         (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb))+                            (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> []))+      ] ++++      optionSolverFlags showOrParseArgs+                        installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })+                        installReorderGoals     (\v flags -> flags { installReorderGoals     = v })+                        installCountConflicts   (\v flags -> flags { installCountConflicts   = v })+                        installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v })+                        installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v })+                        installIndependentGoals (\v flags -> flags { installIndependentGoals = v })+                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })+                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v })+                        installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v })+                        installOnlyConstrained  (\v flags -> flags { installOnlyConstrained  = v }) ++++      [ option [] ["reinstall"]+          "Install even if it means installing the same version again."+          installReinstall (\v flags -> flags { installReinstall = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["avoid-reinstalls"]+          "Do not select versions that would destructively overwrite installed packages."+          (fmap asBool . installAvoidReinstalls)+          (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v })+          (yesNoOpt showOrParseArgs)++      , option [] ["force-reinstalls"]+          "Reinstall packages even if they will most likely break other installed packages."+          installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["upgrade-dependencies"]+          "Pick the latest version for all dependencies, rather than trying to pick an installed version."+          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["only-dependencies"]+          "Install only the dependencies necessary to build the given packages"+          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["dependencies-only"]+          "A synonym for --only-dependencies"+          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["index-state"]+          ("Use source package index state as it existed at a previous time. " +++           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " +++           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")+          installIndexState (\v flags -> flags { installIndexState = v })+          (reqArg "STATE" (parsecToReadE (const $ "index-state must be a  " +++                                       "unix-timestamps (e.g. '@1474732068'), " +++                                       "a ISO8601 UTC timestamp " +++                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))++      , option [] ["root-cmd"]+          "(No longer supported, do not use.)"+          installRootCmd (\v flags -> flags { installRootCmd = v })+          (reqArg' "COMMAND" toFlag flagToList)++      , option [] ["symlink-bindir"]+          "Add symlinks to installed executables into this directory."+           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })+           (reqArgFlag "DIR")++      , option [] ["build-summary"]+          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"+          installSummaryFile (\v flags -> flags { installSummaryFile = v })+          (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList))++      , option [] ["build-log"]+          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"+          installLogFile (\v flags -> flags { installLogFile = v })+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate))++      , option [] ["remote-build-reporting"]+          "Generate build reports to send to a remote server (none, anonymous or detailed)."+          installBuildReports (\v flags -> flags { installBuildReports = v })+          (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', "+                                            ++ "'anonymous' or 'detailed'")+                                      (toFlag `fmap` parsec))+                          (flagToList . fmap prettyShow))++      , option [] ["report-planning-failure"]+          "Generate build reports when the dependency solver fails. This is used by the Hackage build bot."+          installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v })+          trueArg++      , option "" ["per-component"]+          "Per-component builds when possible"+          installPerComponent (\v flags -> flags { installPerComponent = v })+          (boolOpt [] [])++      , option [] ["one-shot"]+          "Do not record the packages in the world file."+          installOneShot (\v flags -> flags { installOneShot = v })+          (yesNoOpt showOrParseArgs)++      , option [] ["run-tests"]+          "Run package test suites during installation."+          installRunTests (\v flags -> flags { installRunTests = v })+          trueArg++      , optionNumJobs+        installNumJobs (\v flags -> flags { installNumJobs = v })++      , option [] ["keep-going"]+          "After a build failure, continue to build other unaffected packages."+          installKeepGoing (\v flags -> flags { installKeepGoing = v })+          trueArg++      , option [] ["offline"]+          "Don't download packages from the Internet."+          installOfflineMode (\v flags -> flags { installOfflineMode = v })+          (yesNoOpt showOrParseArgs)++      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"+                                        -- avoids+          ParseArgs ->+            [ option [] ["only"]+              "Only installs the package in the current directory."+              installOnly (\v flags -> flags { installOnly = v })+              trueArg ]+          _ -> []+++instance Monoid InstallFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup InstallFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Upload flags+-- ------------------------------------------------------------++-- | Is this a candidate package or a package to be published?+data IsCandidate = IsCandidate | IsPublished+                 deriving Eq++data UploadFlags = UploadFlags {+    uploadCandidate   :: Flag IsCandidate,+    uploadDoc         :: Flag Bool,+    uploadUsername    :: Flag Username,+    uploadPassword    :: Flag Password,+    uploadPasswordCmd :: Flag [String],+    uploadVerbosity   :: Flag Verbosity+  } deriving Generic++defaultUploadFlags :: UploadFlags+defaultUploadFlags = UploadFlags {+    uploadCandidate   = toFlag IsCandidate,+    uploadDoc         = toFlag False,+    uploadUsername    = mempty,+    uploadPassword    = mempty,+    uploadPasswordCmd = mempty,+    uploadVerbosity   = toFlag normal+  }++uploadCommand :: CommandUI UploadFlags+uploadCommand = CommandUI {+    commandName         = "upload",+    commandSynopsis     = "Uploads source packages or documentation to Hackage.",+    commandDescription  = Nothing,+    commandNotes        = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n"+      ++ relevantConfigValuesText ["username", "password", "password-command"],+    commandUsage        = \pname ->+         "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",+    commandDefaultFlags = defaultUploadFlags,+    commandOptions      = \_ ->+      [optionVerbosity uploadVerbosity+       (\v flags -> flags { uploadVerbosity = v })++      ,option [] ["publish"]+        "Publish the package instead of uploading it as a candidate."+        uploadCandidate (\v flags -> flags { uploadCandidate = v })+        (noArg (Flag IsPublished))++      ,option ['d'] ["documentation"]+        ("Upload documentation instead of a source package. "+        ++ "By default, this uploads documentation for a package candidate. "+        ++ "To upload documentation for "+        ++ "a published package, combine with --publish.")+        uploadDoc (\v flags -> flags { uploadDoc = v })+        trueArg++      ,option ['u'] ["username"]+        "Hackage username."+        uploadUsername (\v flags -> flags { uploadUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        uploadPassword (\v flags -> flags { uploadPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))++      ,option ['P'] ["password-command"]+        "Command to get Hackage password."+        uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v })+        (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe))+      ]+  }++instance Monoid UploadFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup UploadFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * Init flags+-- ------------------------------------------------------------++initCommand :: CommandUI IT.InitFlags+initCommand = CommandUI {+    commandName = "init",+    commandSynopsis = "Create a new .cabal package file.",+    commandDescription = Just $ \_ -> wrapText $+         "Create a .cabal, Setup.hs, and optionally a LICENSE file.\n"+      ++ "\n"+      ++ "Calling init with no arguments creates an executable, "+      ++ "guessing as many options as possible. The interactive "+      ++ "mode can be invoked by the -i/--interactive flag, which "+      ++ "will try to guess as much as possible and prompt you for "+      ++ "the rest. You can change init to always be interactive by "+      ++ "setting the interactive flag in your configuration file. "+      ++ "Command-line arguments are provided for scripting purposes.\n",+    commandNotes = Nothing,+    commandUsage = \pname ->+         "Usage: " ++ pname ++ " init [FLAGS]\n",+    commandDefaultFlags = IT.defaultInitFlags,+    commandOptions = initOptions+  }++initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags]+initOptions _ =+  [ option ['i'] ["interactive"]+    "interactive mode."+    IT.interactive (\v flags -> flags { IT.interactive = v })+    (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"]))++  , option ['q'] ["quiet"]+    "Do not generate log messages to stdout."+    IT.quiet (\v flags -> flags { IT.quiet = v })+    trueArg++  , option [] ["no-comments"]+    "Do not generate explanatory comments in the .cabal file."+    IT.noComments (\v flags -> flags { IT.noComments = v })+    trueArg++  , option ['m'] ["minimal"]+    "Generate a minimal .cabal file, that is, do not include extra empty fields.  Also implies --no-comments."+    IT.minimal (\v flags -> flags { IT.minimal = v })+    trueArg++  , option [] ["overwrite"]+    "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."+    IT.overwrite (\v flags -> flags { IT.overwrite = v })+    trueArg++  , option [] ["package-dir", "packagedir"]+    "Root directory of the package (default = current directory)."+    IT.packageDir (\v flags -> flags { IT.packageDir = v })+    (reqArgFlag "DIRECTORY")++  , option ['p'] ["package-name"]+    "Name of the Cabal package to create."+    IT.packageName (\v flags -> flags { IT.packageName = v })+    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++)+                                  (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))++  , option [] ["version"]+    "Initial version of the package."+    IT.version (\v flags -> flags { IT.version = v })+    (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++)+                                  (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))++  , option [] ["cabal-version"]+    "Version of the Cabal specification."+    IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })+    (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++)+                                        (fmap (toFlag . getSpecVersion) parsec))+                            (flagToList . fmap (prettyShow . SpecVersion)))++  , option ['l'] ["license"]+    "Project license."+    IT.license (\v flags -> flags { IT.license = v })+    (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++)+                                  (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))++  , option ['a'] ["author"]+    "Name of the project's author."+    IT.author (\v flags -> flags { IT.author = v })+    (reqArgFlag "NAME")++  , option ['e'] ["email"]+    "Email address of the maintainer."+    IT.email (\v flags -> flags { IT.email = v })+    (reqArgFlag "EMAIL")++  , option ['u'] ["homepage"]+    "Project homepage and/or repository."+    IT.homepage (\v flags -> flags { IT.homepage = v })+    (reqArgFlag "URL")++  , option ['s'] ["synopsis"]+    "Short project synopsis."+    IT.synopsis (\v flags -> flags { IT.synopsis = v })+    (reqArgFlag "TEXT")++  , option ['c'] ["category"]+    "Project category."+    IT.category (\v flags -> flags { IT.category = v })+    (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))+                        (flagToList . fmap (either id show)))++  , option ['x'] ["extra-source-file"]+    "Extra source file to be distributed with tarball."+    IT.extraSrc (\v flags -> flags { IT.extraSrc = v })+    (reqArg' "FILE" (Just . (:[]))+                    (fromMaybe []))++  , option [] ["lib", "is-library"]+    "Build a library."+    IT.packageType (\v flags -> flags { IT.packageType = v })+    (noArg (Flag IT.Library))++  , option [] ["exe", "is-executable"]+    "Build an executable."+    IT.packageType+    (\v flags -> flags { IT.packageType = v })+    (noArg (Flag IT.Executable))++    , option [] ["libandexe", "is-libandexe"]+    "Build a library and an executable."+    IT.packageType+    (\v flags -> flags { IT.packageType = v })+    (noArg (Flag IT.LibraryAndExecutable))++      , option [] ["tests"]+        "Generate a test suite for the library."+        IT.initializeTestSuite+        (\v flags -> flags { IT.initializeTestSuite = v })+        trueArg++      , option [] ["test-dir"]+        "Directory containing tests."+        IT.testDirs (\v flags -> flags { IT.testDirs = v })+        (reqArg' "DIR" (Just . (:[]))+                       (fromMaybe []))++  , option [] ["simple"]+    "Create a simple project with sensible defaults."+    IT.simpleProject+    (\v flags -> flags { IT.simpleProject = v })+    trueArg++  , 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+    (\v flags -> flags { IT.language = v })+    (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++)+                                   (toFlag `fmap` parsec))+                      (flagToList . fmap prettyShow))++  , option ['o'] ["expose-module"]+    "Export a module from the package."+    IT.exposedModules+    (\v flags -> flags { IT.exposedModules = v })+    (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++)+                                 ((Just . (:[])) `fmap` parsec))+                     (maybe [] (fmap prettyShow)))++  , option [] ["extension"]+    "Use a LANGUAGE extension (in the other-extensions field)."+    IT.otherExts+    (\v flags -> flags { IT.otherExts = v })+    (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++)+                                    ((Just . (:[])) `fmap` parsec))+                        (maybe [] (fmap prettyShow)))++  , option ['d'] ["dependency"]+    "Package dependency."+    IT.dependencies (\v flags -> flags { IT.dependencies = v })+    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++)+                                  ((Just . (:[])) `fmap` parsec))+                      (maybe [] (fmap prettyShow)))++  , option [] ["application-dir"]+    "Directory containing package application executable."+    IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v})+    (reqArg' "DIR" (Just . (:[]))+                   (fromMaybe []))++  , option [] ["source-dir", "sourcedir"]+    "Directory containing package library source."+    IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })+    (reqArg' "DIR" (Just . (:[]))+                   (fromMaybe []))++  , option [] ["build-tool"]+    "Required external build tool."+    IT.buildTools (\v flags -> flags { IT.buildTools = v })+    (reqArg' "TOOL" (Just . (:[]))+                    (fromMaybe []))++    -- NB: this is a bit of a transitional hack and will likely be+    -- removed again if `cabal init` is migrated to the v2-* command+    -- framework+  , option "w" ["with-compiler"]+    "give the path to a particular compiler"+    IT.initHcPath (\v flags -> flags { IT.initHcPath = v })+    (reqArgFlag "PATH")++  , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })+  ]++-- ------------------------------------------------------------+-- * Copy and Register+-- ------------------------------------------------------------++copyCommand :: CommandUI CopyFlags+copyCommand = Cabal.copyCommand+ { commandNotes = Just $ \pname ->+    "Examples:\n"+     ++ "  " ++ pname ++ " v1-copy           "+     ++ "    All the components in the package\n"+     ++ "  " ++ pname ++ " v1-copy foo       "+     ++ "    A component (i.e. lib, exe, test suite)"+  , commandUsage = usageAlternatives "v1-copy" $+    [ "[FLAGS]"+    , "COMPONENTS [FLAGS]"+    ]+ }++registerCommand :: CommandUI RegisterFlags+registerCommand = Cabal.registerCommand+ { commandUsage = \pname ->  "Usage: " ++ pname ++ " v1-register [FLAGS]\n" }++-- ------------------------------------------------------------+-- * ActAsSetup flags+-- ------------------------------------------------------------++data ActAsSetupFlags = ActAsSetupFlags {+    actAsSetupBuildType :: Flag BuildType+} deriving Generic++defaultActAsSetupFlags :: ActAsSetupFlags+defaultActAsSetupFlags = ActAsSetupFlags {+    actAsSetupBuildType = toFlag Simple+}++actAsSetupCommand :: CommandUI ActAsSetupFlags+actAsSetupCommand = CommandUI {+  commandName         = "act-as-setup",+  commandSynopsis     = "Run as-if this was a Setup.hs",+  commandDescription  = Nothing,+  commandNotes        = Nothing,+  commandUsage        = \pname ->+    "Usage: " ++ pname ++ " act-as-setup\n",+  commandDefaultFlags = defaultActAsSetupFlags,+  commandOptions      = \_ ->+      [option "" ["build-type"]+         "Use the given build type."+         actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })+         (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++)+                               (fmap toFlag parsec))+                              (map prettyShow . flagToList))+      ]+}++instance Monoid ActAsSetupFlags where+  mempty = gmempty+  mappend = (<>)++instance Semigroup ActAsSetupFlags where+  (<>) = gmappend++-- ------------------------------------------------------------+-- * UserConfig flags+-- ------------------------------------------------------------++data UserConfigFlags = UserConfigFlags {+  userConfigVerbosity   :: Flag Verbosity,+  userConfigForce       :: Flag Bool,+  userConfigAppendLines :: Flag [String]+  } deriving Generic++instance Monoid UserConfigFlags where+  mempty = UserConfigFlags {+    userConfigVerbosity   = toFlag normal,+    userConfigForce       = toFlag False,+    userConfigAppendLines = toFlag []+    }+  mappend = (<>)++instance Semigroup UserConfigFlags where+  (<>) = gmappend++userConfigCommand :: CommandUI UserConfigFlags+userConfigCommand = CommandUI {+  commandName         = "user-config",+  commandSynopsis     = "Display and update the user's global cabal configuration.",+  commandDescription  = Just $ \_ -> wrapText $+       "When upgrading cabal, the set of configuration keys and their default"+    ++ " values may change. This command provides means to merge the existing"+    ++ " config in ~/.cabal/config"+    ++ " (i.e. all bindings that are actually defined and not commented out)"+    ++ " and the default config of the new version.\n"+    ++ "\n"+    ++ "init: Creates a new config file at either ~/.cabal/config or as"+    ++ " specified by --config-file, if given. An existing file won't be "+    ++ " overwritten unless -f or --force is given.\n"+    ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and"+    ++ " the default configuration that would be created by cabal if the"+    ++ " config file did not exist.\n"+    ++ "update: Applies the pseudo-diff to the configuration that would be"+    ++ " created by default, and write the result back to ~/.cabal/config.",++  commandNotes        = Nothing,+  commandUsage        = usageAlternatives "user-config" ["init", "diff", "update"],+  commandDefaultFlags = mempty,+  commandOptions      = \ _ -> [+   optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })+ , option ['f'] ["force"]+     "Overwrite the config file if it already exists."+     userConfigForce (\v flags -> flags { userConfigForce = v })+     trueArg+ , option ['a'] ["augment"]+     "Additional setting to augment the config file (replacing a previous setting if it existed)."+     userConfigAppendLines (\v flags -> flags+                               {userConfigAppendLines =+                                   Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)})+     (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe))+   ]+  }+++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++reqArgFlag :: ArgPlaceHolder ->+              MkOptDescr (b -> Flag String) (Flag String -> b -> b) b+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList++liftOptions :: (b -> a) -> (a -> b -> b)+            -> [OptionField a] -> [OptionField b]+liftOptions get set = map (liftOption get set)++yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b+yesNoOpt ShowArgs sf lf = trueArg sf lf+yesNoOpt _        sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf++optionSolver :: (flags -> Flag PreSolver)+             -> (Flag PreSolver -> flags -> flags)+             -> OptionField flags+optionSolver get set =+  option [] ["solver"]+    ("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")+    get set+    (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers)+                                    (toFlag `fmap` parsec))+                     (flagToList . fmap prettyShow))++optionSolverFlags :: ShowOrParseArgs+                  -> (flags -> Flag Int   ) -> (Flag Int    -> flags -> flags)+                  -> (flags -> Flag ReorderGoals)     -> (Flag ReorderGoals     -> flags -> flags)+                  -> (flags -> Flag CountConflicts)   -> (Flag CountConflicts   -> flags -> flags)+                  -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags)+                  -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags)+                  -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)+                  -> (flags -> Flag ShadowPkgs)       -> (Flag ShadowPkgs       -> flags -> flags)+                  -> (flags -> Flag StrongFlags)      -> (Flag StrongFlags      -> flags -> flags)+                  -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags)+                  -> (flags -> Flag OnlyConstrained)  -> (Flag OnlyConstrained  -> flags -> flags)+                  -> [OptionField flags]+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc+                  getfgc setfgc getmc setmc getig setig getsip setsip+                  getstrfl setstrfl getib setib getoc setoc =+  [ option [] ["max-backjumps"]+      ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")+      getmbj setmbj+      (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral))+                    (map show . flagToList))+  , option [] ["reorder-goals"]+      "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."+      (fmap asBool . getrg)+      (setrg . fmap ReorderGoals)+      (yesNoOpt showOrParseArgs)+  , option [] ["count-conflicts"]+      "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)."+      (fmap asBool . getcc)+      (setcc . fmap CountConflicts)+      (yesNoOpt showOrParseArgs)+  , option [] ["fine-grained-conflicts"]+      "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)."+      (fmap asBool . getfgc)+      (setfgc . fmap FineGrainedConflicts)+      (yesNoOpt showOrParseArgs)+  , option [] ["minimize-conflict-set"]+      ("When there is no solution, try to improve the error message by finding "+        ++ "a minimal conflict set (default: false). May increase run time "+        ++ "significantly.")+      (fmap asBool . getmc)+      (setmc . fmap MinimizeConflictSet)+      (yesNoOpt showOrParseArgs)+  , option [] ["independent-goals"]+      "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."+      (fmap asBool . getig)+      (setig . fmap IndependentGoals)+      (yesNoOpt showOrParseArgs)+  , option [] ["shadow-installed-packages"]+      "If multiple package instances of the same version are installed, treat all but one as shadowed."+      (fmap asBool . getsip)+      (setsip . fmap ShadowPkgs)+      (yesNoOpt showOrParseArgs)+  , option [] ["strong-flags"]+      "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."+      (fmap asBool . getstrfl)+      (setstrfl . fmap StrongFlags)+      (yesNoOpt showOrParseArgs)+  , option [] ["allow-boot-library-installs"]+      "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell."+      (fmap asBool . getib)+      (setib . fmap AllowBootLibInstalls)+      (yesNoOpt showOrParseArgs)+  , option [] ["reject-unconstrained-dependencies"]+      "Require these packages to have constraints on them if they are to be selected (default: none)."+      getoc+      setoc+      (reqArg "none|all"+         (parsecToReadE+            (const "reject-unconstrained-dependencies must be 'none' or 'all'")+            (toFlag `fmap` parsec))+         (flagToList . fmap prettyShow))++  ]++usagePackages :: String -> String -> String+usagePackages name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"++usageFlags :: String -> String -> String+usageFlags name pname =+  "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"++-- ------------------------------------------------------------+-- * Repo helpers+-- ------------------------------------------------------------++showRemoteRepo :: RemoteRepo -> String+showRemoteRepo = prettyShow++readRemoteRepo :: String -> Maybe RemoteRepo+readRemoteRepo = simpleParsec++showLocalRepo :: LocalRepo -> String+showLocalRepo = prettyShow++readLocalRepo :: String -> Maybe LocalRepo+readLocalRepo = simpleParsec++-- ------------------------------------------------------------+-- * Helpers for Documentation+-- ------------------------------------------------------------++relevantConfigValuesText :: [String] -> String+relevantConfigValuesText vs =+     "Relevant global configuration keys:\n"+  ++ concat ["  " ++ v ++ "\n" |v <- vs]
+ src/Distribution/Client/SetupWrapper.hs view
@@ -0,0 +1,919 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.SetupWrapper+-- Copyright   :  (c) The University of Glasgow 2006,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  alpha+-- Portability :  portable+--+-- An interface to building and installing Cabal packages.+-- If the @Built-Type@ field is specified as something other than+-- 'Custom', and the current version of Cabal is acceptable, this performs+-- setup actions directly.  Otherwise it builds the setup script and+-- runs it with the given arguments.++module Distribution.Client.SetupWrapper (+    getSetup, runSetup, runSetupCommand, setupWrapper,+    SetupScriptOptions(..),+    defaultSetupScriptOptions,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)+import qualified Distribution.Make as Make+import qualified Distribution.Simple as Simple+import Distribution.Version+         ( Version, mkVersion, versionNumbers, VersionRange, anyVersion+         , intersectVersionRanges, orLaterVersion+         , withinRange )+import qualified Distribution.Backpack as Backpack+import Distribution.Package+         ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId+         , PackageId, mkPackageName+         , PackageIdentifier(..), packageVersion, packageName )+import Distribution.PackageDescription+         ( GenericPackageDescription(packageDescription)+         , PackageDescription(..), specVersion, buildType+         , BuildType(..) )+import Distribution.Types.ModuleRenaming (defaultRenaming)+import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription )+import Distribution.Simple.Configure+         ( configCompilerEx )+import Distribution.Compiler+         ( buildCompilerId, CompilerFlavor(GHC, GHCJS) )+import Distribution.Simple.Compiler+         ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack )+import Distribution.Simple.PreProcess+         ( runSimplePreProcessor, ppUnlit )+import Distribution.Simple.Build.Macros+         ( generatePackageVersionMacros )+import Distribution.Simple.Program+         ( ProgramDb, emptyProgramDb+         , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram+         , ghcjsProgram )+import Distribution.Simple.Program.Find+         ( programSearchPathAsPATHVar+         , ProgramSearchPathEntry(ProgramSearchPathDir) )+import Distribution.Simple.Program.Run+         ( getEffectiveEnvironment )+import qualified Distribution.Simple.Program.Strip as Strip+import Distribution.Simple.BuildPaths+         ( defaultDistPref, exeExtension )++import Distribution.Simple.Command+         ( CommandUI(..), commandShowOptions )+import Distribution.Simple.Program.GHC+         ( GhcMode(..), GhcOptions(..), renderGhcOptions )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (InstalledPackageIndex)+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Client.Types+import Distribution.Client.Config+         ( getCabalDir )+import Distribution.Client.IndexUtils+         ( getInstalledPackages )+import Distribution.Client.JobControl+         ( Lock, criticalSection )+import Distribution.Simple.Setup+         ( Flag(..) )+import Distribution.Utils.Generic+         ( safeHead )+import Distribution.Simple.Utils+         ( die', debug, info, infoNoWrap+         , cabalVersion, tryFindPackageDesc+         , createDirectoryIfMissingVerbose, installExecutableFile+         , copyFileVerbose, rewriteFileEx, rewriteFileLBS )+import Distribution.Client.Utils+         ( inDir, tryCanonicalizePath, withExtraPathEnv+         , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides+#ifdef mingw32_HOST_OS+         , canonicalizePathNoThrow+#endif+         )++import Distribution.ReadE+import Distribution.System ( Platform(..), buildPlatform )+import Distribution.Utils.NubList+         ( toNubListR )+import Distribution.Verbosity+import Distribution.Compat.Stack++import System.Directory    ( doesFileExist )+import System.FilePath     ( (</>), (<.>) )+import System.IO           ( Handle, hPutStr )+import Distribution.Compat.Process (createProcess)+import System.Process      ( StdStream(..), proc, waitForProcess+                           , ProcessHandle )+import qualified System.Process as Process+import Data.List           ( foldl1' )+import Distribution.Client.Compat.ExecutablePath  ( getExecutablePath )++import qualified Data.ByteString.Lazy as BS++#ifdef mingw32_HOST_OS+import Distribution.Simple.Utils+         ( withTempDirectory )++import Control.Exception   ( bracket )+import System.FilePath     ( equalFilePath, takeDirectory )+import System.Directory    ( doesDirectoryExist )+import qualified System.Win32 as Win32+#endif++-- | @Setup@ encapsulates the outcome of configuring a setup method to build a+-- particular package.+data Setup = Setup { setupMethod        :: SetupMethod+                   , setupScriptOptions :: SetupScriptOptions+                   , setupVersion       :: Version+                   , setupBuildType     :: BuildType+                   , setupPackage       :: PackageDescription+                   }++-- | @SetupMethod@ represents one of the methods used to run Cabal commands.+data SetupMethod = InternalMethod+                   -- ^ run Cabal commands through \"cabal\" in the+                   -- current process+                 | SelfExecMethod+                   -- ^ run Cabal commands through \"cabal\" as a+                   -- child process+                 | ExternalMethod FilePath+                   -- ^ run Cabal commands through a custom \"Setup\" executable++-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two+-- parts: one that has no policy and just does as it's told with all the+-- explicit options, and an optional initial part that applies certain+-- policies (like if we should add the Cabal lib as a dep, and if so which+-- version). This could be structured as an action that returns a fully+-- elaborated 'SetupScriptOptions' containing no remaining policy choices.+--+-- See also the discussion at https://github.com/haskell/cabal/pull/3094++-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as+-- opposed to options given to the Cabal command at runtime.+data SetupScriptOptions = SetupScriptOptions {+    -- | The version of the Cabal library to use (if 'useDependenciesExclusive'+    -- is not set). A suitable version of the Cabal library must be installed+    -- (or for some build-types be the one cabal-install was built with).+    --+    -- The version found also determines the version of the Cabal specification+    -- that we us for talking to the Setup.hs, unless overridden by+    -- 'useCabalSpecVersion'.+    --+    useCabalVersion          :: VersionRange,++    -- | This is the version of the Cabal specification that we believe that+    -- this package uses. This affects the semantics and in particular the+    -- Setup command line interface.+    --+    -- This is similar to 'useCabalVersion' but instead of probing the system+    -- for a version of the /Cabal library/ you just say exactly which version+    -- of the /spec/ we will use. Using this also avoid adding the Cabal+    -- library as an additional dependency, so add it to 'useDependencies'+    -- if needed.+    --+    useCabalSpecVersion      :: Maybe Version,+    useCompiler              :: Maybe Compiler,+    usePlatform              :: Maybe Platform,+    usePackageDB             :: PackageDBStack,+    usePackageIndex          :: Maybe InstalledPackageIndex,+    useProgramDb             :: ProgramDb,+    useDistPref              :: FilePath,+    useLoggingHandle         :: Maybe Handle,+    useWorkingDir            :: Maybe FilePath,+    -- | Extra things to add to PATH when invoking the setup script.+    useExtraPathEnv          :: [FilePath],+    -- | Extra environment variables paired with overrides, where+    --+    -- * @'Just' v@ means \"set the environment variable's value to @v@\".+    -- * 'Nothing' means \"unset the environment variable\".+    useExtraEnvOverrides     :: [(String, Maybe FilePath)],+    forceExternalSetupMethod :: Bool,++    -- | List of dependencies to use when building Setup.hs.+    useDependencies :: [(ComponentId, PackageId)],++    -- | Is the list of setup dependencies exclusive?+    --+    -- When this is @False@, if we compile the Setup.hs script we do so with the+    -- list in 'useDependencies' but all other packages in the environment are+    -- also visible. A suitable version of @Cabal@ library (see+    -- 'useCabalVersion') is also added to the list of dependencies, unless+    -- 'useDependencies' already contains a Cabal dependency.+    --+    -- When @True@, only the 'useDependencies' packages are used, with other+    -- packages in the environment hidden.+    --+    -- This feature is here to support the setup stanza in .cabal files that+    -- specifies explicit (and exclusive) dependencies, as well as the old+    -- style with no dependencies.+    useDependenciesExclusive :: Bool,++    -- | Should we build the Setup.hs with CPP version macros available?+    -- We turn this on when we have a setup stanza in .cabal that declares+    -- explicit setup dependencies.+    --+    useVersionMacros         :: Bool,++    -- Used only by 'cabal clean' on Windows.+    --+    -- Note: win32 clean hack+    -------------------------+    -- On Windows, running './dist/setup/setup clean' doesn't work because the+    -- setup script will try to delete itself (which causes it to fail horribly,+    -- unlike on Linux). So we have to move the setup exe out of the way first+    -- and then delete it manually. This applies only to the external setup+    -- method.+    useWin32CleanHack        :: Bool,++    -- Used only when calling setupWrapper from parallel code to serialise+    -- access to the setup cache; should be Nothing otherwise.+    --+    -- Note: setup exe cache+    ------------------------+    -- When we are installing in parallel, we always use the external setup+    -- method. Since compiling the setup script each time adds noticeable+    -- overhead, we use a shared setup script cache+    -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal+    -- version) combination the cache holds a compiled setup script+    -- executable. This only affects the Simple build type; for the Custom,+    -- Configure and Make build types we always compile the setup script anew.+    setupCacheLock           :: Maybe Lock,++    -- | Is the task we are going to run an interactive foreground task,+    -- or an non-interactive background task? Based on this flag we+    -- decide whether or not to delegate ctrl+c to the spawned task+    isInteractive            :: Bool+  }++defaultSetupScriptOptions :: SetupScriptOptions+defaultSetupScriptOptions = SetupScriptOptions {+    useCabalVersion          = anyVersion,+    useCabalSpecVersion      = Nothing,+    useCompiler              = Nothing,+    usePlatform              = Nothing,+    usePackageDB             = [GlobalPackageDB, UserPackageDB],+    usePackageIndex          = Nothing,+    useDependencies          = [],+    useDependenciesExclusive = False,+    useVersionMacros         = False,+    useProgramDb             = emptyProgramDb,+    useDistPref              = defaultDistPref,+    useLoggingHandle         = Nothing,+    useWorkingDir            = Nothing,+    useExtraPathEnv          = [],+    useExtraEnvOverrides     = [],+    useWin32CleanHack        = False,+    forceExternalSetupMethod = False,+    setupCacheLock           = Nothing,+    isInteractive            = False+  }++workingDir :: SetupScriptOptions -> FilePath+workingDir options =+  case fromMaybe "" (useWorkingDir options) of+    []  -> "."+    dir -> dir++-- | A @SetupRunner@ implements a 'SetupMethod'.+type SetupRunner = Verbosity+                 -> SetupScriptOptions+                 -> BuildType+                 -> [String]+                 -> IO ()++-- | Prepare to build a package by configuring a 'SetupMethod'. The returned+-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed+-- during the configuration process; the final values are given by+-- 'setupScriptOptions'.+getSetup :: Verbosity+         -> SetupScriptOptions+         -> Maybe PackageDescription+         -> IO Setup+getSetup verbosity options mpkg = do+  pkg <- maybe getPkg return mpkg+  let options'    = options {+                      useCabalVersion = intersectVersionRanges+                                          (useCabalVersion options)+                                          (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))+                    }+      buildType'  = buildType pkg+  (version, method, options'') <-+    getSetupMethod verbosity options' pkg buildType'+  return Setup { setupMethod = method+               , setupScriptOptions = options''+               , setupVersion = version+               , setupBuildType = buildType'+               , setupPackage = pkg+               }+  where+    getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options))+         >>= readGenericPackageDescription verbosity+         >>= return . packageDescription++-- | Decide if we're going to be able to do a direct internal call to the+-- entry point in the Cabal library or if we're going to have to compile+-- and execute an external Setup.hs script.+--+getSetupMethod+  :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType+  -> IO (Version, SetupMethod, SetupScriptOptions)+getSetupMethod verbosity options pkg buildType'+  | buildType' == Custom+    || maybe False (cabalVersion /=) (useCabalSpecVersion options)+    || not (cabalVersion `withinRange` useCabalVersion options)    =+         getExternalSetupMethod verbosity options pkg buildType'+  | isJust (useLoggingHandle options)+    -- Forcing is done to use an external process e.g. due to parallel+    -- build concerns.+    || forceExternalSetupMethod options =+        return (cabalVersion, SelfExecMethod, options)+  | otherwise = return (cabalVersion, InternalMethod, options)++runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)+runSetupMethod InternalMethod = internalSetupMethod+runSetupMethod (ExternalMethod path) = externalSetupMethod path+runSetupMethod SelfExecMethod = selfExecSetupMethod++-- | Run a configured 'Setup' with specific arguments.+runSetup :: Verbosity -> Setup+         -> [String]  -- ^ command-line arguments+         -> IO ()+runSetup verbosity setup args0 = do+  let method = setupMethod setup+      options = setupScriptOptions setup+      bt = setupBuildType setup+      args = verbosityHack (setupVersion setup) args0+  when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $+    infoNoWrap verbose $+        "Applied verbosity hack:\n" +++        "  Before: " ++ show args0 ++ "\n" +++        "  After:  " ++ show args ++ "\n"+  runSetupMethod method verbosity options bt args++-- | This is a horrible hack to make sure passing fancy verbosity+-- flags (e.g., @-v'info +callstack'@) doesn't break horribly on+-- old Setup.  We can't do it in 'filterConfigureFlags' because+-- verbosity applies to ALL commands.+verbosityHack :: Version -> [String] -> [String]+verbosityHack ver args0+    | ver >= mkVersion [2,1]  = args0+    | otherwise = go args0+  where+    go (('-':'v':rest) : args)+        | Just rest' <- munch rest = ("-v" ++ rest') : go args+    go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args)+        | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args+    go ("--verbose" : rest : args)+        | Just rest' <- munch rest = "--verbose" : rest' : go args+    go rest@("--" : _) = rest+    go (arg:args) = arg : go args+    go [] = []++    munch rest =+        case runReadE flagToVerbosity rest of+            Right v+              | ver < mkVersion [2,0], verboseHasFlags v+              -- We could preserve the prefix, but since we're assuming+              -- it's Cabal's verbosity flag, we can assume that+              -- any format is OK+              -> Just (showForCabal (verboseNoFlags v))+              | ver < mkVersion [2,1], isVerboseTimestamp v+              -- +timestamp wasn't yet available in Cabal-2.0.0+              -> Just (showForCabal (verboseNoTimestamp v))+            _ -> Nothing++-- | Run a command through a configured 'Setup'.+runSetupCommand :: Verbosity -> Setup+                -> CommandUI flags  -- ^ command definition+                -> flags  -- ^ command flags+                -> [String] -- ^ extra command-line arguments+                -> IO ()+runSetupCommand verbosity setup cmd flags extraArgs = do+  let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs+  runSetup verbosity setup args++-- | Configure a 'Setup' and run a command in one step. The command flags+-- may depend on the Cabal library version in use.+setupWrapper :: Verbosity+             -> SetupScriptOptions+             -> Maybe PackageDescription+             -> CommandUI flags+             -> (Version -> flags)+                -- ^ produce command flags given the Cabal library version+             -> (Version -> [String])+             -> IO ()+setupWrapper verbosity options mpkg cmd flags extraArgs = do+  setup <- getSetup verbosity options mpkg+  runSetupCommand verbosity setup+                  cmd (flags $ setupVersion setup)+                      (extraArgs $ setupVersion setup)++-- ------------------------------------------------------------+-- * Internal SetupMethod+-- ------------------------------------------------------------++internalSetupMethod :: SetupRunner+internalSetupMethod verbosity options bt args = do+  info verbosity $ "Using internal setup method with build-type " ++ show bt+                ++ " and args:\n  " ++ show args+  inDir (useWorkingDir options) $ do+    withEnv "HASKELL_DIST_DIR" (useDistPref options) $+      withExtraPathEnv (useExtraPathEnv options) $+        withEnvOverrides (useExtraEnvOverrides options) $+          buildTypeAction bt args++buildTypeAction :: BuildType -> ([String] -> IO ())+buildTypeAction Simple    = Simple.defaultMainArgs+buildTypeAction Configure = Simple.defaultMainWithHooksArgs+                              Simple.autoconfUserHooks+buildTypeAction Make      = Make.defaultMainArgs+buildTypeAction Custom               = error "buildTypeAction Custom"+++-- | @runProcess'@ is a version of @runProcess@ where we have+-- the additional option to decide whether or not we should+-- delegate CTRL+C to the spawned process.+runProcess' :: FilePath                 -- ^ Filename of the executable+            -> [String]                 -- ^ Arguments to pass to executable+            -> Maybe FilePath           -- ^ Optional path to working directory+            -> Maybe [(String, String)] -- ^ Optional environment+            -> Maybe Handle             -- ^ Handle for @stdin@+            -> Maybe Handle             -- ^ Handle for @stdout@+            -> Maybe Handle             -- ^ Handle for @stderr@+            -> Bool                     -- ^ Delegate Ctrl+C ?+            -> IO ProcessHandle+runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do+  (_,_,_,ph) <-+    createProcess+      (proc cmd args){ Process.cwd = mb_cwd+                     , Process.env = mb_env+                     , Process.std_in  = mbToStd mb_stdin+                     , Process.std_out = mbToStd mb_stdout+                     , Process.std_err = mbToStd mb_stderr+                     , Process.delegate_ctlc = _delegate+                     }+  return ph+  where+    mbToStd :: Maybe Handle -> StdStream+    mbToStd Nothing = Inherit+    mbToStd (Just hdl) = UseHandle hdl++-- ------------------------------------------------------------+-- * Self-Exec SetupMethod+-- ------------------------------------------------------------++selfExecSetupMethod :: SetupRunner+selfExecSetupMethod verbosity options bt args0 = do+  let args = ["act-as-setup",+              "--build-type=" ++ prettyShow bt,+              "--"] ++ args0+  info verbosity $ "Using self-exec internal setup method with build-type "+                 ++ show bt ++ " and args:\n  " ++ show args+  path <- getExecutablePath+  info verbosity $ unwords (path : args)+  case useLoggingHandle options of+    Nothing        -> return ()+    Just logHandle -> info verbosity $ "Redirecting build log to "+                                    ++ show logHandle++  searchpath <- programSearchPathAsPATHVar+                (map ProgramSearchPathDir (useExtraPathEnv options) +++                 getProgramSearchPath (useProgramDb options))+  env       <- getEffectiveEnvironment $+                 [ ("PATH", Just searchpath)+                 , ("HASKELL_DIST_DIR", Just (useDistPref options))+                 ] ++ useExtraEnvOverrides options+  process <- runProcess' path args+             (useWorkingDir options) env Nothing+             (useLoggingHandle options) (useLoggingHandle options)+             (isInteractive options)+  exitCode <- waitForProcess process+  unless (exitCode == ExitSuccess) $ exitWith exitCode++-- ------------------------------------------------------------+-- * External SetupMethod+-- ------------------------------------------------------------++externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)+externalSetupMethod path verbosity options _ args = do+  info verbosity $ unwords (path : args)+  case useLoggingHandle options of+    Nothing        -> return ()+    Just logHandle -> info verbosity $ "Redirecting build log to "+                                    ++ show logHandle++  -- See 'Note: win32 clean hack' above.+#ifdef mingw32_HOST_OS+  if useWin32CleanHack options then doWin32CleanHack path else doInvoke path+#else+  doInvoke path+#endif++  where+    doInvoke path' = do+      searchpath <- programSearchPathAsPATHVar+                    (map ProgramSearchPathDir (useExtraPathEnv options) +++                      getProgramSearchPath (useProgramDb options))+      env        <- getEffectiveEnvironment $+                      [ ("PATH", Just searchpath)+                      , ("HASKELL_DIST_DIR", Just (useDistPref options))+                      ] ++ useExtraEnvOverrides options++      debug verbosity $ "Setup arguments: "++unwords args+      process <- runProcess' path' args+                  (useWorkingDir options) env Nothing+                  (useLoggingHandle options) (useLoggingHandle options)+                  (isInteractive options)+      exitCode <- waitForProcess process+      unless (exitCode == ExitSuccess) $ exitWith exitCode++#ifdef mingw32_HOST_OS+    doWin32CleanHack path' = do+      info verbosity $ "Using the Win32 clean hack."+      -- Recursively removes the temp dir on exit.+      withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->+          bracket (moveOutOfTheWay tmpDir path')+                  (maybeRestore path')+                  doInvoke++    moveOutOfTheWay tmpDir path' = do+      let newPath = tmpDir </> "setup" <.> exeExtension buildPlatform+      Win32.moveFile path' newPath+      return newPath++    maybeRestore oldPath path' = do+      let oldPathDir = takeDirectory oldPath+      oldPathDirExists <- doesDirectoryExist oldPathDir+      -- 'setup clean' didn't complete, 'dist/setup' still exists.+      when oldPathDirExists $+        Win32.moveFile path' oldPath+#endif++getExternalSetupMethod+  :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType+  -> IO (Version, SetupMethod, SetupScriptOptions)+getExternalSetupMethod verbosity options pkg bt = do+  debug verbosity $ "Using external setup method with build-type " ++ show bt+  debug verbosity $ "Using explicit dependencies: "+    ++ show (useDependenciesExclusive options)+  createDirectoryIfMissingVerbose verbosity True setupDir+  (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse+  debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion+  path <- if useCachedSetupExecutable+          then getCachedSetupExecutable options'+               cabalLibVersion mCabalLibInstalledPkgId+          else compileSetupExecutable   options'+               cabalLibVersion mCabalLibInstalledPkgId False++  -- Since useWorkingDir can change the relative path, the path argument must+  -- be turned into an absolute path. On some systems, runProcess' will take+  -- path as relative to the new working directory instead of the current+  -- working directory.+  path' <- tryCanonicalizePath path++  -- See 'Note: win32 clean hack' above.+#ifdef mingw32_HOST_OS+  -- setupProgFile may not exist if we're using a cached program+  setupProgFile' <- canonicalizePathNoThrow setupProgFile+  let win32CleanHackNeeded = (useWin32CleanHack options)+                              -- Skip when a cached setup script is used.+                              && setupProgFile' `equalFilePath` path'+#else+  let win32CleanHackNeeded = False+#endif+  let options'' = options' { useWin32CleanHack = win32CleanHackNeeded }++  return (cabalLibVersion, ExternalMethod path', options'')++  where+  setupDir         = workingDir options </> useDistPref options </> "setup"+  setupVersionFile = setupDir   </> "setup" <.> "version"+  setupHs          = setupDir   </> "setup" <.> "hs"+  setupProgFile    = setupDir   </> "setup" <.> exeExtension buildPlatform+  platform         = fromMaybe buildPlatform (usePlatform options)++  useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)++  maybeGetInstalledPackages :: SetupScriptOptions -> Compiler+                            -> ProgramDb -> IO InstalledPackageIndex+  maybeGetInstalledPackages options' comp progdb =+    case usePackageIndex options' of+      Just index -> return index+      Nothing    -> getInstalledPackages verbosity+                    comp (usePackageDB options') progdb++  -- Choose the version of Cabal to use if the setup script has a dependency on+  -- Cabal, and possibly update the setup script options. The version also+  -- determines how to filter the flags to Setup.+  --+  -- We first check whether the dependency solver has specified a Cabal version.+  -- If it has, we use the solver's version without looking at the installed+  -- package index (See issue #3436). Otherwise, we pick the Cabal version by+  -- checking 'useCabalSpecVersion', then the saved version, and finally the+  -- versions available in the index.+  --+  -- The version chosen here must match the one used in 'compileSetupExecutable'+  -- (See issue #3433).+  cabalLibVersionToUse :: IO (Version, Maybe ComponentId+                             ,SetupScriptOptions)+  cabalLibVersionToUse =+    case find (isCabalPkgId . snd) (useDependencies options) of+      Just (unitId, pkgId) -> do+        let version = pkgVersion pkgId+        updateSetupScript version bt+        writeSetupVersionFile version+        return (version, Just unitId, options)+      Nothing ->+        case useCabalSpecVersion options of+          Just version -> do+            updateSetupScript version bt+            writeSetupVersionFile version+            return (version, Nothing, options)+          Nothing  -> do+            savedVer <- savedVersion+            case savedVer of+              Just version | version `withinRange` useCabalVersion 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++      writeSetupVersionFile :: Version -> IO ()+      writeSetupVersionFile version =+          writeFile setupVersionFile (show version ++ "\n")++      installedVersion :: IO (Version, Maybe InstalledPackageId+                             ,SetupScriptOptions)+      installedVersion = do+        (comp,    progdb,  options')  <- configureCompiler options+        (version, mipkgid, options'') <- installedCabalVersion options'+                                         comp progdb+        updateSetupScript version bt+        writeSetupVersionFile version+        return (version, mipkgid, 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' verbosity+      "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 options </> "Setup.hs"+      customSetupLhs  = workingDir options </> "Setup.lhs"++  updateSetupScript cabalLibVersion _ =+    rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion)++  buildTypeScript :: Version -> BS.ByteString+  buildTypeScript cabalLibVersion = case bt of+    Simple                                            -> "import Distribution.Simple; main = defaultMain\n"+    Configure | cabalLibVersion >= mkVersion [1,3,10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"+              | otherwise                             -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"+    Make                                              -> "import Distribution.Make; main = defaultMain\n"+    Custom                                            -> error "buildTypeScript Custom"++  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb+                        -> IO (Version, Maybe InstalledPackageId+                              ,SetupScriptOptions)+  installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal"+                                       && bt == Custom =+    return (packageVersion pkg, Nothing, options')+  installedCabalVersion options' compiler progdb = do+    index <- maybeGetInstalledPackages options' compiler progdb+    let cabalDepName    = mkPackageName "Cabal"+        cabalDepVersion = useCabalVersion options'+        options''       = options' { usePackageIndex = Just index }+    case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of+      []   -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg)+                 ++ "' requires Cabal library version "+                 ++ prettyShow (useCabalVersion options)+                 ++ " but no suitable version is installed."+      pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs+                  err = error "Distribution.Client.installedCabalVersion: empty version list"+              in return (packageVersion ipkginfo+                        ,Just . IPI.installedComponentId $ ipkginfo, options'')++  bestVersion :: (a -> Version) -> [a] -> a+  bestVersion f = firstMaximumBy (comparing (preference . f))+    where+      -- Like maximumBy, but picks the first maximum element instead of the+      -- last. In general, we expect the preferred version to go first in the+      -- list. For the default case, this has the effect of choosing the version+      -- installed in the user package DB instead of the global one. See #1463.+      --+      -- Note: firstMaximumBy could be written as just+      -- `maximumBy cmp . reverse`, but the problem is that the behaviour of+      -- maximumBy is not fully specified in the case when there is not a single+      -- greatest element.+      firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a+      firstMaximumBy _ []   =+        error "Distribution.Client.firstMaximumBy: empty list"+      firstMaximumBy cmp xs =  foldl1' maxBy xs+        where+          maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; }++      preference version   = (sameVersion, sameMajorVersion+                             ,stableVersion, latestVersion)+        where+          sameVersion      = version == cabalVersion+          sameMajorVersion = majorVersion version == majorVersion cabalVersion+          majorVersion     = take 2 . versionNumbers+          stableVersion    = case versionNumbers version of+                               (_:x:_) -> even x+                               _       -> False+          latestVersion    = version++  configureCompiler :: SetupScriptOptions+                    -> IO (Compiler, ProgramDb, SetupScriptOptions)+  configureCompiler options' = do+    (comp, progdb) <- case useCompiler options' of+      Just comp -> return (comp, useProgramDb options')+      Nothing   -> do (comp, _, progdb) <-+                        configCompilerEx (Just GHC) Nothing Nothing+                        (useProgramDb options') verbosity+                      return (comp, progdb)+    -- Whenever we need to call configureCompiler, we also need to access the+    -- package index, so let's cache it in SetupScriptOptions.+    index <- maybeGetInstalledPackages options' comp progdb+    return (comp, progdb, options' { useCompiler      = Just comp,+                                     usePackageIndex  = Just index,+                                     useProgramDb = progdb })++  -- | 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 <- getCabalDir+    let setupCacheDir       = cabalDir </> "setup-exe-cache"+        cachedSetupProgFile = setupCacheDir+                              </> ("setup-" ++ buildTypeString ++ "-"+                                   ++ cabalVersionString ++ "-"+                                   ++ platformString ++ "-"+                                   ++ compilerVersionString)+                              <.> exeExtension buildPlatform+    return (setupCacheDir, cachedSetupProgFile)+      where+        buildTypeString       = show bt+        cabalVersionString    = "Cabal-" ++ prettyShow cabalLibVersion+        compilerVersionString = prettyShow $+                                maybe buildCompilerId compilerId+                                  $ useCompiler options'+        platformString        = prettyShow platform++  -- | Look up the setup executable in the cache; update the cache if the setup+  -- executable is not found.+  getCachedSetupExecutable :: SetupScriptOptions+                           -> Version -> Maybe InstalledPackageId+                           -> IO FilePath+  getCachedSetupExecutable options' cabalLibVersion+                           maybeCabalLibInstalledPkgId = do+    (setupCacheDir, cachedSetupProgFile) <-+      cachedSetupDirAndProg options' cabalLibVersion+    cachedSetupExists <- doesFileExist cachedSetupProgFile+    if cachedSetupExists+      then debug verbosity $+           "Found cached setup executable: " ++ cachedSetupProgFile+      else criticalSection' $ do+        -- The cache may have been populated while we were waiting.+        cachedSetupExists' <- doesFileExist cachedSetupProgFile+        if cachedSetupExists'+          then debug verbosity $+               "Found cached setup executable: " ++ cachedSetupProgFile+          else do+          debug verbosity $ "Setup executable not found in the cache."+          src <- compileSetupExecutable options'+                 cabalLibVersion maybeCabalLibInstalledPkgId True+          createDirectoryIfMissingVerbose verbosity True setupCacheDir+          installExecutableFile verbosity src cachedSetupProgFile+          -- Do not strip if we're using GHCJS, since the result may be a script+          when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $+            Strip.stripExe verbosity platform (useProgramDb options')+              cachedSetupProgFile+    return cachedSetupProgFile+      where+        criticalSection' = maybe id criticalSection $ setupCacheLock options'++  -- | If the Setup.hs is out of date wrt the executable then recompile it.+  -- Currently this is GHC/GHCJS only. It should really be generalised.+  --+  compileSetupExecutable :: SetupScriptOptions+                         -> Version -> Maybe ComponentId -> Bool+                         -> IO FilePath+  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, progdb, options'') <- configureCompiler options'+      let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion+          (program, extraOpts)+            = case compilerFlavor compiler of+                      GHCJS -> (ghcjsProgram, ["-build-runner"])+                      _     -> (ghcProgram,   ["-threaded"])+          cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])+                              maybeCabalLibInstalledPkgId++          -- With 'useDependenciesExclusive' we enforce the deps specified,+          -- so only the given ones can be used. Otherwise we allow the use+          -- of packages in the ambient environment, and add on a dep on the+          -- Cabal library (unless 'useDependencies' already contains one).+          --+          -- With 'useVersionMacros' we use a version CPP macros .h file.+          --+          -- Both of these options should be enabled for packages that have+          -- opted-in and declared a custom-settup stanza.+          --+          selectedDeps | useDependenciesExclusive options'+                                   = useDependencies options'+                       | otherwise = useDependencies options' +++                                     if any (isCabalPkgId . snd)+                                        (useDependencies options')+                                     then []+                                     else cabalDep+          addRenaming (ipid, _) =+            -- Assert 'DefUnitId' invariant+            (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))+            ,defaultRenaming)+          cppMacrosFile = setupDir </> "setup_macros.h"+          ghcOptions = mempty {+              -- Respect -v0, but don't crank up verbosity on GHC if+              -- Cabal verbosity is requested. For that, use+              -- --ghc-option=-v instead!+              ghcOptVerbosity       = Flag (min verbosity normal)+            , ghcOptMode            = Flag GhcModeMake+            , ghcOptInputFiles      = toNubListR [setupHs]+            , ghcOptOutputFile      = Flag setupProgFile+            , ghcOptObjDir          = Flag setupDir+            , ghcOptHiDir           = Flag setupDir+            , ghcOptSourcePathClear = Flag True+            , ghcOptSourcePath      = case bt of+                                      Custom -> toNubListR [workingDir options']+                                      _      -> mempty+            , ghcOptPackageDBs      = usePackageDB options''+            , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')+            , ghcOptCabal           = Flag (useDependenciesExclusive options')+            , ghcOptPackages        = toNubListR $ map addRenaming selectedDeps+            , ghcOptCppIncludes     = toNubListR [ cppMacrosFile+                                                 | useVersionMacros options' ]+            , ghcOptExtra           = extraOpts+            }+      let ghcCmdLine = renderGhcOptions compiler platform ghcOptions+      when (useVersionMacros options') $+        rewriteFileEx verbosity cppMacrosFile+          $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)+      case useLoggingHandle options of+        Nothing          -> runDbProgram verbosity program progdb ghcCmdLine++        -- If build logging is enabled, redirect compiler output to+        -- the log file.+        (Just logHandle) -> do output <- getDbProgramOutput verbosity program+                                         progdb ghcCmdLine+                               hPutStr logHandle output+    return setupProgFile+++isCabalPkgId :: PackageIdentifier -> Bool+isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
+ src/Distribution/Client/SolverInstallPlan.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.SolverInstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'SolverInstallPlan' is the graph of packages produced by the+-- dependency solver, and specifies at the package-granularity what+-- things are going to be installed.  To put it another way: the+-- dependency solver produces a 'SolverInstallPlan', which is then+-- consumed by various other parts of Cabal.+--+-----------------------------------------------------------------------------+module Distribution.Client.SolverInstallPlan(+  SolverInstallPlan(..),+  SolverPlanPackage,+  ResolverPackage(..),++  -- * Operations on 'SolverInstallPlan's+  new,+  toList,+  toMap,++  remove,++  showPlanIndex,+  showInstallPlan,++  -- * Checking validity of plans+  valid,+  closed,+  consistent,+  acyclic,++  -- ** Details on invalid plans+  SolverPlanProblem(..),+  showPlanProblem,+  problems,++  -- ** Querying the install plan+  dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,+) where++import Distribution.Client.Compat.Prelude hiding (toList)+import Prelude ()++import Distribution.Package+         ( PackageIdentifier(..), Package(..), PackageName+         , HasUnitId(..), PackageId, packageVersion, packageName )+import Distribution.Types.Flag (nullFlagAssignment)+import qualified Distribution.Solver.Types.ComponentDeps as CD++import Distribution.Client.Types+         ( UnresolvedPkgLoc )+import Distribution.Version+         ( Version )++import           Distribution.Solver.Types.Settings+import           Distribution.Solver.Types.ResolverPackage+import           Distribution.Solver.Types.SolverId+import           Distribution.Solver.Types.SolverPackage++import Distribution.Compat.Graph (Graph, IsNode(..))+import qualified Data.Foldable as Foldable+import qualified Data.Graph as OldGraph+import qualified Distribution.Compat.Graph as Graph+import qualified Data.Map as Map+import Data.Array ((!))++type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc++type SolverPlanIndex = Graph SolverPlanPackage++data SolverInstallPlan = SolverInstallPlan {+    planIndex      :: !SolverPlanIndex,+    planIndepGoals :: !IndependentGoals+  }+  deriving (Typeable, Generic)++{-+-- | Much like 'planPkgIdOf', but mapping back to full packages.+planPkgOf :: SolverInstallPlan+          -> Graph.Vertex+          -> SolverPlanPackage+planPkgOf plan v =+    case Graph.lookupKey (planIndex plan)+                         (planPkgIdOf plan v) of+      Just pkg -> pkg+      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"+-}++++instance Binary SolverInstallPlan+instance Structured SolverInstallPlan++showPlanIndex :: [SolverPlanPackage] -> String+showPlanIndex = intercalate "\n" . map showPlanPackage++showInstallPlan :: SolverInstallPlan -> String+showInstallPlan = showPlanIndex . toList++showPlanPackage :: SolverPlanPackage -> String+showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg)+                                            ++ " (" ++ prettyShow (installedUnitId ipkg)+                                            ++ ")"+showPlanPackage (Configured  spkg) =+    "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps+  where+    flags+        | nullFlagAssignment fa = ""+        | otherwise             = " " ++ prettyShow (solverPkgFlags spkg)+      where+        fa = solverPkgFlags spkg++    comps | null deps = ""+          | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps)+      where+        deps = CD.components (solverPkgLibDeps spkg)+             <> CD.components (solverPkgExeDeps spkg)++-- | Build an installation plan from a valid set of resolved packages.+--+new :: IndependentGoals+    -> SolverPlanIndex+    -> Either [SolverPlanProblem] SolverInstallPlan+new indepGoals index =+  case problems indepGoals index of+    []    -> Right (SolverInstallPlan index indepGoals)+    probs -> Left probs++toList :: SolverInstallPlan -> [SolverPlanPackage]+toList = Foldable.toList . planIndex++toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage+toMap = Graph.toMap . planIndex++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (SolverPlanPackage -> Bool)+       -> SolverInstallPlan+       -> Either [SolverPlanProblem]+                 (SolverInstallPlan)+remove shouldRemove plan =+    new (planIndepGoals plan) newIndex+  where+    newIndex = Graph.fromDistinctList $+                 filter (not . shouldRemove) (toList plan)++-- ------------------------------------------------------------+-- * Checking validity of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is 'acyclic',+-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the+-- plan has to have a valid configuration (see 'configuredPackageValid').+--+-- * if the result is @False@ use 'problems' to get a detailed list.+--+valid :: IndependentGoals+      -> SolverPlanIndex+      -> Bool+valid indepGoals index =+    null $ problems indepGoals index++data SolverPlanProblem =+     PackageMissingDeps   SolverPlanPackage+                          [PackageIdentifier]+   | PackageCycle         [SolverPlanPackage]+   | PackageInconsistency PackageName [(PackageIdentifier, Version)]+   | PackageStateInvalid  SolverPlanPackage SolverPlanPackage++showPlanProblem :: SolverPlanProblem -> String+showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ prettyShow (packageId pkg)+  ++ " depends on the following packages which are missing from the plan: "+  ++ intercalate ", " (map prettyShow missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (prettyShow.packageId) cycleGroup)++showPlanProblem (PackageInconsistency name inconsistencies) =+     "Package " ++ prettyShow name+  ++ " is required by several packages,"+  ++ " but they require inconsistent versions:\n"+  ++ unlines [ "  package " ++ prettyShow pkg ++ " requires "+                            ++ prettyShow (PackageIdentifier name ver)+             | (pkg, ver) <- inconsistencies ]++showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ prettyShow (packageId pkg)+  ++ " is in the " ++ showPlanState pkg+  ++ " state but it depends on package " ++ prettyShow (packageId pkg')+  ++ " which is in the " ++ showPlanState pkg'+  ++ " state"+  where+    showPlanState (PreExisting _) = "pre-existing"+    showPlanState (Configured  _)   = "configured"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: IndependentGoals+         -> SolverPlanIndex+         -> [SolverPlanProblem]+problems indepGoals index =++     [ PackageMissingDeps pkg+       (mapMaybe+         (fmap packageId . flip Graph.lookup index)+         missingDeps)+     | (pkg, missingDeps) <- Graph.broken index ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- Graph.cycles index ]++  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <-+       dependencyInconsistencies indepGoals index ]++  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- Foldable.toList index+     , Just pkg' <- map (flip Graph.lookup index)+                    (nodeNeighbors pkg)+     , not (stateDependencyRelation pkg pkg') ]+++-- | Compute all roots of the install plan, and verify that the transitive+-- plans from those roots are all consistent.+--+-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles+-- may be absent from the subplans even if the larger plan contains a dependency+-- cycle. Such cycles may or may not be an issue; either way, we don't check+-- for them here.+dependencyInconsistencies :: IndependentGoals+                          -> SolverPlanIndex+                          -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies indepGoals index  =+    concatMap dependencyInconsistencies' subplans+  where+    subplans :: [SolverPlanIndex]+    subplans = -- Not Graph.closure!!+               map (nonSetupClosure index)+                   (rootSets indepGoals index)++-- NB: When we check for inconsistencies, packages from the setup+-- scripts don't count as part of the closure (this way, we+-- can build, e.g., Cabal-1.24.1 even if its setup script is+-- built with Cabal-1.24.0).+--+-- This is a best effort function that swallows any non-existent+-- SolverIds.+nonSetupClosure :: SolverPlanIndex+                -> [SolverId]+                -> SolverPlanIndex+nonSetupClosure index pkgids0 = closure Graph.empty pkgids0+ where+    closure completed []             = completed+    closure completed (pkgid:pkgids) =+      case Graph.lookup pkgid index of+        Nothing   -> closure completed pkgids+        Just pkg  ->+          case Graph.lookup (nodeKey pkg) completed of+            Just _  -> closure completed  pkgids+            Nothing -> closure completed' pkgids'+              where completed' = Graph.insert pkg completed+                    pkgids'    = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids++-- | Compute the root sets of a plan+--+-- A root set is a set of packages whose dependency closure must be consistent.+-- This is the set of all top-level library roots (taken together normally, or+-- as singletons sets if we are considering them as independent goals), along+-- with all setup dependencies of all packages.+rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]]+rootSets (IndependentGoals indepGoals) index =+       if indepGoals then map (:[]) libRoots else [libRoots]+    ++ setupRoots index+  where+    libRoots = libraryRoots index++-- | Compute the library roots of a plan+--+-- The library roots are the set of packages with no reverse dependencies+-- (no reverse library dependencies but also no reverse setup dependencies).+libraryRoots :: SolverPlanIndex -> [SolverId]+libraryRoots index =+    map (nodeKey . toPkgId) roots+  where+    (graph, toPkgId, _) = Graph.toGraph index+    indegree = OldGraph.indegree graph+    roots    = filter isRoot (OldGraph.vertices graph)+    isRoot v = indegree ! v == 0++-- | The setup dependencies of each package in the plan+setupRoots :: SolverPlanIndex -> [[SolverId]]+setupRoots = filter (not . null)+           . map (CD.setupDeps . resolverPackageLibDeps)+           . Foldable.toList++-- | Given a package index where we assume we want to use all the packages+-- (use 'dependencyClosure' if you need to get such a index subset) find out+-- if the dependencies within it use consistent versions of each package.+-- Return all cases where multiple packages depend on different versions of+-- some other package.+--+-- Each element in the result is a package name along with the packages that+-- depend on it and the versions they require. These are guaranteed to be+-- distinct.+--+dependencyInconsistencies' :: SolverPlanIndex+                           -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies' index =+    [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids])+    | (name, ipid_map) <- Map.toList inverseIndex+    , let uses = Map.elems ipid_map+    , reallyIsInconsistent (map fst uses)+    ]+  where+    -- For each package name (of a dependency, somewhere)+    --   and each installed ID of that package+    --     the associated package instance+    --     and a list of reverse dependencies (as source IDs)+    inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId]))+    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))+      [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))])+      | -- For each package @pkg@+        pkg <- Foldable.toList index+        -- Find out which @sid@ @pkg@ depends on+      , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg)+        -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@)+      , Just dep <- [Graph.lookup sid index]+      ]++    -- If, in a single install plan, we depend on more than one version of a+    -- package, then this is ONLY okay in the (rather special) case that we+    -- depend on precisely two versions of that package, and one of them+    -- depends on the other. This is necessary for example for the base where+    -- we have base-3 depending on base-4.+    reallyIsInconsistent :: [SolverPlanPackage] -> Bool+    reallyIsInconsistent []       = False+    reallyIsInconsistent [_p]     = False+    reallyIsInconsistent [p1, p2] =+      let pid1 = nodeKey p1+          pid2 = nodeKey p2+      in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2)+      && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1)+    reallyIsInconsistent _ = True+++-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.+--+-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out+--   which packages are involved in dependency cycles.+--+acyclic :: SolverPlanIndex -> Bool+acyclic = null . Graph.cycles++-- | An installation plan is closed if for every package in the set, all of+-- its dependencies are also in the set. That is, the set is closed under the+-- dependency relation.+--+-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out+--   which packages depend on packages not in the index.+--+closed :: SolverPlanIndex -> Bool+closed = null . Graph.broken++-- | An installation plan is consistent if all dependencies that target a+-- single package name, target the same version.+--+-- This is slightly subtle. It is not the same as requiring that there be at+-- 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+-- 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 approximation of that.+--+-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to+--   find out which packages are.+--+consistent :: SolverPlanIndex -> Bool+consistent = null . dependencyInconsistencies (IndependentGoals False)++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @dependencyStatesOk a b = True@.+--+stateDependencyRelation :: SolverPlanPackage+                        -> SolverPlanPackage+                        -> Bool+stateDependencyRelation PreExisting{}   PreExisting{}     = True++stateDependencyRelation (Configured  _) PreExisting{}     = True+stateDependencyRelation (Configured  _) (Configured  _)   = True++stateDependencyRelation _               _                 = False+++-- | Compute the dependency closure of a package in a install plan+--+dependencyClosure :: SolverInstallPlan+                  -> [SolverId]+                  -> [SolverPlanPackage]+dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan)+++reverseDependencyClosure :: SolverInstallPlan+                         -> [SolverId]+                         -> [SolverPlanPackage]+reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan)+++topologicalOrder :: SolverInstallPlan+                 -> [SolverPlanPackage]+topologicalOrder plan = Graph.topSort (planIndex plan)+++reverseTopologicalOrder :: SolverInstallPlan+                        -> [SolverPlanPackage]+reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan)
+ src/Distribution/Client/SourceFiles.hs view
@@ -0,0 +1,161 @@+-- | Contains an @sdist@ like function which computes the source files+-- that we should track to determine if a rebuild is necessary.+-- Unlike @sdist@, we can operate directly on the true+-- 'PackageDescription' (not flattened).+--+-- The naming convention, roughly, is that to declare we need the+-- source for some type T, you use the function needT; some functions+-- need auxiliary information.+--+-- We can only use this code for non-Custom scripts; Custom scripts+-- may have arbitrary extra dependencies (esp. new preprocessors) which+-- we cannot "see" easily.+module Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) where++import Distribution.Client.ProjectPlanning.Types+import Distribution.Client.RebuildMonad++import Distribution.Solver.Types.OptionalStanza++import Distribution.Simple.PreProcess++import Distribution.Types.PackageDescription+import Distribution.Types.Component+import Distribution.Types.Library+import Distribution.Types.Executable+import Distribution.Types.Benchmark+import Distribution.Types.BenchmarkInterface+import Distribution.Types.TestSuite+import Distribution.Types.TestSuiteInterface+import Distribution.Types.BuildInfo+import Distribution.Types.ForeignLib+import Distribution.Utils.Path++import Distribution.ModuleName++import Prelude ()+import Distribution.Client.Compat.Prelude++import System.FilePath++needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild ()+needElaboratedConfiguredPackage elab =+    case elabPkgOrComp elab of+        ElabComponent ecomp -> needElaboratedComponent elab ecomp+        ElabPackage   epkg  -> needElaboratedPackage   elab epkg++needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild ()+needElaboratedPackage elab epkg =+    traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)+  where+    pkg_descr = elabPkgDescription elab+    enabled_stanzas = pkgStanzasEnabled epkg+    enabled = enableStanzas enabled_stanzas++needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild ()+needElaboratedComponent elab ecomp =+    case mb_comp of+        Nothing   -> needSetup+        Just comp -> needComponent pkg_descr comp+  where+    pkg_descr = elabPkgDescription elab+    mb_comp   = fmap (getComponent pkg_descr) (compComponentName ecomp)++needComponent :: PackageDescription -> Component -> Rebuild ()+needComponent pkg_descr comp =+    case comp of+        CLib lib     -> needLibrary    pkg_descr lib+        CFLib flib   -> needForeignLib pkg_descr flib+        CExe exe     -> needExecutable pkg_descr exe+        CTest test   -> needTestSuite  pkg_descr test+        CBench bench -> needBenchmark  pkg_descr bench++needSetup :: Rebuild ()+needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return ()++needLibrary :: PackageDescription -> Library -> Rebuild ()+needLibrary pkg_descr (Library { exposedModules = modules+                               , signatures     = sigs+                               , libBuildInfo   = bi })+  = needBuildInfo pkg_descr bi (modules ++ sigs)++needForeignLib :: PackageDescription -> ForeignLib -> Rebuild ()+needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs+                                     , foreignLibBuildInfo = bi })+  = do traverse_ needIfExists fs+       needBuildInfo pkg_descr bi []++needExecutable :: PackageDescription -> Executable -> Rebuild ()+needExecutable pkg_descr (Executable { modulePath = mainPath+                                     , buildInfo  = bi })+  = do needBuildInfo pkg_descr bi []+       needMainFile  bi mainPath++needTestSuite :: PackageDescription -> TestSuite -> Rebuild ()+needTestSuite pkg_descr t+  = case testInterface t of+      TestSuiteExeV10 _ mainPath -> do+        needBuildInfo pkg_descr bi []+        needMainFile  bi mainPath+      TestSuiteLibV09 _ m ->+        needBuildInfo pkg_descr bi [m]+      TestSuiteUnsupported _ -> return () -- soft fail+ where+  bi = testBuildInfo t++needMainFile :: BuildInfo -> FilePath -> Rebuild ()+needMainFile bi mainPath = do+    -- The matter here is subtle.  It might *seem* that we+    -- should just search for mainPath, but as per+    -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is'+    -- will actually be the source file AFTER preprocessing,+    -- whereas we need to get the file *prior* to preprocessing.+    ppFile <- findFileWithExtensionMonitored+                (ppSuffixes knownSuffixHandlers)+                (map getSymbolicPath (hsSourceDirs bi))+                (dropExtension mainPath)+    case ppFile of+        -- But check the original path in the end, because+        -- maybe it's a non-preprocessed file with a non-traditional+        -- extension.+        Nothing -> findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath+                    >>= maybe (return ()) need+        Just pp -> need pp++needBenchmark :: PackageDescription -> Benchmark -> Rebuild ()+needBenchmark pkg_descr bm+  = case benchmarkInterface bm of+     BenchmarkExeV10 _ mainPath -> do+       needBuildInfo pkg_descr bi []+       needMainFile  bi mainPath+     BenchmarkUnsupported _ -> return () -- soft fail+ where+  bi = benchmarkBuildInfo bm++needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild ()+needBuildInfo pkg_descr bi modules = do+    -- NB: These are separate because there may be both A.hs and+    -- A.hs-boot; need to track both.+    findNeededModules ["hs", "lhs", "hsig", "lhsig"]+    findNeededModules ["hs-boot", "lhs-boot"]+    traverse_ needIfExists $ concat+        [ cSources bi+        , cxxSources bi+        , jsSources bi+        , cmmSources bi+        , asmSources bi+        , extraSrcFiles pkg_descr+        ]+    for_ (installIncludes bi) $ \f ->+        findFileMonitored ("." : includeDirs bi) f+            >>= maybe (return ()) need+  where+    findNeededModules exts = traverse_+        (findNeededModule exts)+        (modules ++ otherModules bi)+    findNeededModule exts m =+        findFileWithExtensionMonitored+            (ppSuffixes knownSuffixHandlers ++ exts)+            (map getSymbolicPath (hsSourceDirs bi))+            (toFilePath m)+          >>= maybe (return ()) need
+ src/Distribution/Client/SrcDist.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Utilities to implemenet cabal @v2-sdist@.+module Distribution.Client.SrcDist (+    allPackageSourceFiles,+    packageDirToSdist,+)  where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Control.Monad.State.Lazy  (StateT, evalStateT, gets, modify)+import Control.Monad.Trans       (liftIO)+import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)+import System.FilePath           (normalise, takeDirectory, (</>))++import Distribution.Client.Utils                     (tryFindAddSourcePackageDesc)+import Distribution.Package                          (Package (packageId))+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parsec        (readGenericPackageDescription)+import Distribution.Simple.PreProcess                (knownSuffixHandlers)+import Distribution.Simple.SrcDist                   (listPackageSourcesWithDie)+import Distribution.Simple.Utils                     (die')+import Distribution.Types.GenericPackageDescription  (GenericPackageDescription)++import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip  as GZip+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Lazy    as BSL+import qualified Data.Set                as Set++-- | List all source files of a given add-source dependency. Exits with error if+-- something is wrong (e.g. there is no .cabal file in the given directory).+--+-- Used in sandbox and projectbuilding.+-- TODO: when sandboxes are removed, move to ProjectBuilding.+--+allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]+allPackageSourceFiles verbosity packageDir = do+  pd <- do+    let err = "Error reading source files of package."+    desc <- tryFindAddSourcePackageDesc verbosity packageDir err+    flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc++  listPackageSourcesWithDie verbosity (\_ _ -> return []) packageDir pd knownSuffixHandlers++-- | Create a tarball for a package in a directory+packageDirToSdist+    :: Verbosity+    -> GenericPackageDescription  -- ^ read in GPD+    -> FilePath                   -- ^ directory containing that GPD+    -> IO BSL.ByteString          -- ^ resulting sdist tarball+packageDirToSdist verbosity gpd dir = do+    let thisDie :: Verbosity -> String -> IO a+        thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s++    files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers+    let files = nub $ sort $ map normalise files'++    let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()+        entriesM = do+            let prefix = prettyShow (packageId gpd)+            modify (Set.insert prefix)+            case Tar.toTarPath True prefix of+                Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)+                Right path -> tell [Tar.directoryEntry path]++            for_ files $ \file -> do+                let fileDir = takeDirectory (prefix </> file)+                needsEntry <- gets (Set.notMember fileDir)++                when needsEntry $ do+                    modify (Set.insert fileDir)+                    case Tar.toTarPath True fileDir of+                        Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)+                        Right path -> tell [Tar.directoryEntry path]++                contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file+                case Tar.toTarPath False (prefix </> file) of+                    Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)+                    Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]++    entries <- execWriterT (evalStateT entriesM mempty)+    let -- Pretend our GZip file is made on Unix.+        normalize bs = BSL.concat [pfx, "\x03", rest']+            where+                (pfx, rest) = BSL.splitAt 9 bs+                rest' = BSL.tail rest+        -- The Unix epoch, which is the default value, is+        -- unsuitable because it causes unpacking problems on+        -- Windows; we need a post-1980 date. One gigasecond+        -- after the epoch is during 2001-09-09, so that does+        -- nicely. See #5596.+        setModTime entry = entry { Tar.entryTime = 1000000000 }+    return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
+ src/Distribution/Client/Store.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}+++-- | Management for the installed package store.+--+module Distribution.Client.Store (++    -- * The store layout+    StoreDirLayout(..),+    defaultStoreDirLayout,++    -- * Reading store entries+    getStoreEntries,+    doesStoreEntryExist,++    -- * Creating store entries+    newStoreEntry,+    NewStoreEntryOutcome(..),++    -- * Concurrency strategy+    -- $concurrency+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import           Distribution.Client.DistDirLayout+import           Distribution.Client.RebuildMonad++import           Distribution.Package (UnitId, mkUnitId)+import           Distribution.Compiler (CompilerId)++import           Distribution.Simple.Utils+                   ( withTempDirectory, debug, info )+import           Distribution.Verbosity+                   ( silent )++import qualified Data.Set as Set+import           Control.Exception+import           System.FilePath+import           System.Directory++#ifdef MIN_VERSION_lukko+import Lukko+#else+import System.IO (openFile, IOMode(ReadWriteMode), hClose)+import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))+#if MIN_VERSION_base(4,11,0)+import GHC.IO.Handle.Lock (hUnlock)+#endif+#endif++-- $concurrency+--+-- We access and update the store concurrently. Our strategy to do that safely+-- is as follows.+--+-- The store entries once created are immutable. This alone simplifies matters+-- considerably.+--+-- Additionally, the way 'UnitId' hashes are constructed means that if a store+-- entry exists already then we can assume its content is ok to reuse, rather+-- than having to re-recreate. This is the nix-style input hashing concept.+--+-- A consequence of this is that with a little care it is /safe/ to race+-- updates against each other. Consider two independent concurrent builds that+-- both want to build a particular 'UnitId', where that entry does not yet+-- exist in the store. It is safe for both to build and try to install this+-- entry into the store provided that:+--+-- * only one succeeds+-- * the looser discovers that they lost, they abandon their own build and+--   re-use the store entry installed by the winner.+--+-- Note that because builds are not reproducible in general (nor even+-- necessarily ABI compatible) then it is essential that the loser abandon+-- their build and use the one installed by the winner, so that subsequent+-- packages are built against the exact package from the store rather than some+-- morally equivalent package that may not be ABI compatible.+--+-- Our overriding goal is that store reads be simple, cheap and not require+-- locking. We will derive our write-side protocol to make this possible.+--+-- The read-side protocol is simply:+--+-- * check for the existence of a directory entry named after the 'UnitId' in+--   question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then+--   the store entry can be assumed to be complete and immutable.+--+-- Given our read-side protocol, the final step on the write side must be to+-- atomically rename a fully-formed store entry directory into its final+-- location. While this will indeed be the final step, the preparatory steps+-- are more complicated. The tricky aspect is that the store also contains a+-- number of shared package databases (one per compiler version). Our read+-- strategy means that by the time we install the store dir entry the package+-- db must already have been updated. We cannot do the package db update+-- as part of atomically renaming the store entry directory however. Furthermore+-- it is not safe to allow either package db update because the db entry+-- contains the ABI hash and this is not guaranteed to be deterministic. So we+-- must register the new package prior to the atomic dir rename. Since this+-- combination of steps are not atomic then we need locking.+--+-- The write-side protocol is:+--+-- * Create a unique temp dir and write all store entry files into it.+--+-- * Take a lock named after the 'UnitId' in question.+--+-- * Once holding the lock, check again for the existence of the final store+--   entry directory. If the entry exists then the process lost the race and it+--   must abandon, unlock and re-use the existing store entry. If the entry+--   does not exist then the process won the race and it can proceed.+--+-- * Register the package into the package db. Note that the files are not in+--   their final location at this stage so registration file checks may need+--   to be disabled.+--+-- * Atomically rename the temp dir to the final store entry location.+--+-- * Release the previously-acquired lock.+--+-- Obviously this means it is possible to fail after registering but before+-- installing the store entry, leaving a dangling package db entry. This is not+-- much of a problem because this entry does not determine package existence+-- for cabal. It does mean however that the package db update should be insert+-- or replace, i.e. not failing if the db entry already exists.+++-- | Check if a particular 'UnitId' exists in the store.+--+doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool+doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid =+    doesDirectoryExist (storePackageDirectory compid unitid)+++-- | Return the 'UnitId's of all packages\/components already installed in the+-- store.+--+getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)+getStoreEntries StoreDirLayout{storeDirectory} compid = do+    paths <- getDirectoryContentsMonitored (storeDirectory compid)+    return $! mkEntries paths+  where+    mkEntries     = Set.delete (mkUnitId "package.db")+                  . Set.delete (mkUnitId "incoming")+                  . Set.fromList+                  . map mkUnitId+                  . filter valid+    valid ('.':_) = False+    valid _       = True+++-- | The outcome of 'newStoreEntry': either the store entry was newly created+-- or it existed already. The latter case happens if there was a race between+-- two builds of the same store entry.+--+data NewStoreEntryOutcome = UseNewStoreEntry+                          | UseExistingStoreEntry+  deriving (Eq, Show)++-- | Place a new entry into the store. See the concurrency strategy description+-- for full details.+--+-- In particular, it takes two actions: one to place files into a temporary+-- location, and a second to perform any necessary registration. The first+-- action is executed without any locks held (the temp dir is unique). The+-- second action holds a lock that guarantees that only one cabal process is+-- able to install this store entry. This means it is safe to register into+-- the compiler package DB or do other similar actions.+--+-- Note that if you need to use the registration information later then you+-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry'+-- then you must read the existing registration information (unless your+-- registration information is constructed fully deterministically).+--+newStoreEntry :: Verbosity+              -> StoreDirLayout+              -> CompilerId+              -> UnitId+              -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files.+              -> IO ()                     -- ^ Register action, if necessary.+              -> IO NewStoreEntryOutcome+newStoreEntry verbosity storeDirLayout@StoreDirLayout{..}+              compid unitid+              copyFiles register =+    -- See $concurrency above for an explanation of the concurrency protocol++    withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do++      -- Write all store entry files within the temp dir and return the prefix.+      (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir++      -- Take a lock named after the 'UnitId' in question.+      withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do++        -- Check for the existence of the final store entry directory.+        exists <- doesStoreEntryExist storeDirLayout compid unitid++        if exists+          -- If the entry exists then we lost the race and we must abandon,+          -- unlock and re-use the existing store entry.+          then do+            info verbosity $+                "Concurrent build race: abandoning build in favour of existing "+             ++ "store entry " ++ prettyShow compid </> prettyShow unitid+            return UseExistingStoreEntry++          -- If the entry does not exist then we won the race and can proceed.+          else do++            -- Register the package into the package db (if appropriate).+            register++            -- Atomically rename the temp dir to the final store entry location.+            renameDirectory incomingEntryDir finalEntryDir+            for_ otherFiles $ \file -> do+              let finalStoreFile = storeDirectory compid </> makeRelative (incomingTmpDir </> (dropDrive (storeDirectory compid))) file+              createDirectoryIfMissing True (takeDirectory finalStoreFile)+              renameFile file finalStoreFile++            debug verbosity $+              "Installed store entry " ++ prettyShow compid </> prettyShow unitid+            return UseNewStoreEntry+  where+    finalEntryDir = storePackageDirectory compid unitid+++withTempIncomingDir :: StoreDirLayout -> CompilerId+                    -> (FilePath -> IO a) -> IO a+withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do+    createDirectoryIfMissing True incomingDir+    withTempDirectory silent incomingDir "new" action+  where+    incomingDir = storeIncomingDirectory compid+++withIncomingUnitIdLock :: Verbosity -> StoreDirLayout+                       -> CompilerId -> UnitId+                       -> IO a -> IO a+withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock}+                       compid unitid action =+    bracket takeLock releaseLock (\_hnd -> action)+  where+#ifdef MIN_VERSION_lukko+    takeLock+        | fileLockingSupported = do+            fd <- fdOpen (storeIncomingLock compid unitid)+            gotLock <- fdTryLock fd ExclusiveLock+            unless gotLock  $ do+                info verbosity $ "Waiting for file lock on store entry "+                              ++ prettyShow compid </> prettyShow unitid+                fdLock fd ExclusiveLock+            return fd++        -- if there's no locking, do nothing. Be careful on AIX.+        | otherwise = return undefined -- :(++    releaseLock fd+        | fileLockingSupported = do+            fdUnlock fd+            fdClose fd+        | otherwise = return ()+#else+    takeLock = do+      h <- openFile (storeIncomingLock compid unitid) ReadWriteMode+      -- First try non-blocking, but if we would have to wait then+      -- log an explanation and do it again in blocking mode.+      gotlock <- hTryLock h ExclusiveLock+      unless gotlock $ do+        info verbosity $ "Waiting for file lock on store entry "+                      ++ prettyShow compid </> prettyShow unitid+        hLock h ExclusiveLock+      return h++    releaseLock h = hUnlock h >> hClose h+#endif
+ src/Distribution/Client/Tar.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Tar+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008-2009 Duncan Coutts+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-- Reading, writing and manipulating \"@.tar@\" archive files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Tar (+  -- * @tar.gz@ operations+  createTarGzFile,+  extractTarGzFile,++  -- * Other local utils+  buildTreeRefTypeCode,+  buildTreeSnapshotTypeCode,+  isBuildTreeRefTypeCode,+  filterEntries,+  filterEntriesM,+  entriesToList,+  ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Data.ByteString.Lazy    as BS+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Check as Tar+import qualified Codec.Compression.GZip  as GZip+import qualified Distribution.Client.GZipUtils as GZipUtils++-- for foldEntries...+import Control.Exception (throw)++--+-- * High level operations+--++createTarGzFile :: FilePath  -- ^ Full Tarball path+                -> FilePath  -- ^ Base directory+                -> FilePath  -- ^ Directory to archive, relative to base dir+                -> IO ()+createTarGzFile tar base dir =+  BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]++extractTarGzFile :: FilePath -- ^ Destination directory+                 -> FilePath -- ^ Expected subdir (to check for tarbombs)+                 -> FilePath -- ^ Tarball+                -> IO ()+extractTarGzFile dir expected tar =+  Tar.unpack dir . Tar.checkTarbomb expected . Tar.read+  . GZipUtils.maybeDecompress =<< BS.readFile tar++instance (Exception a, Exception b) => Exception (Either a b) where+  toException (Left  e) = toException e+  toException (Right e) = toException e++  fromException e =+    case fromException e of+      Just e' -> Just (Left e')+      Nothing -> case fromException e of+                   Just e' -> Just (Right e')+                   Nothing -> Nothing+++-- | Type code for the local build tree reference entry type. We don't use the+-- symbolic link entry type because it allows only 100 ASCII characters for the+-- path.+buildTreeRefTypeCode :: Tar.TypeCode+buildTreeRefTypeCode = 'C'++-- | Type code for the local build tree snapshot entry type.+buildTreeSnapshotTypeCode :: Tar.TypeCode+buildTreeSnapshotTypeCode = 'S'++-- | Is this a type code for a build tree reference?+isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool+isBuildTreeRefTypeCode typeCode+  | (typeCode == buildTreeRefTypeCode+     || typeCode == buildTreeSnapshotTypeCode) = True+  | otherwise                                  = False++filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e+filterEntries p =+  Tar.foldEntries+    (\e es -> if p e then Tar.Next e es else es)+    Tar.Done+    Tar.Fail++filterEntriesM :: Monad m => (Tar.Entry -> m Bool)+               -> Tar.Entries e -> m (Tar.Entries e)+filterEntriesM p =+  Tar.foldEntries+    (\entry rest -> do+         keep <- p entry+         xs   <- rest+         if keep+           then return (Tar.Next entry xs)+           else return xs)+    (return Tar.Done)+    (return . Tar.Fail)++entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]+entriesToList = Tar.foldEntries (:) [] throw+
+ src/Distribution/Client/TargetProblem.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveFunctor #-}+module Distribution.Client.TargetProblem (+    TargetProblem(..),+    TargetProblem',+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Client.ProjectPlanning    (AvailableTarget)+import Distribution.Client.TargetSelector     (SubComponentTarget, TargetSelector)+import Distribution.Package                   (PackageId, PackageName)+import Distribution.Simple.LocalBuildInfo     (ComponentName (..))+import Distribution.Types.UnqualComponentName (UnqualComponentName)++-- | Target problems that occur during project orchestration.+data TargetProblem a+    = TargetNotInProject                   PackageName+    | TargetAvailableInIndex               PackageName++    | TargetComponentNotProjectLocal+      PackageId ComponentName SubComponentTarget++    | TargetComponentNotBuildable+      PackageId ComponentName SubComponentTarget++    | TargetOptionalStanzaDisabledByUser+      PackageId ComponentName SubComponentTarget++    | TargetOptionalStanzaDisabledBySolver+      PackageId ComponentName SubComponentTarget++    | TargetProblemUnknownComponent+      PackageName (Either UnqualComponentName ComponentName)++    | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]+      -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable++    | TargetProblemNoTargets TargetSelector+      -- ^ There are no targets at all++    -- The target matching stuff only returns packages local to the project,+    -- so these lookups should never fail, but if 'resolveTargets' is called+    -- directly then of course it can.+    | TargetProblemNoSuchPackage           PackageId+    | TargetProblemNoSuchComponent         PackageId ComponentName++      -- | A custom target problem+    | CustomTargetProblem a+  deriving (Eq, Show, Functor)++-- | Type alias for a 'TargetProblem' with no user-defined problems/errors.+--+-- Can use the utilities below for reporting/rendering problems.+type TargetProblem' = TargetProblem Void
+ src/Distribution/Client/TargetSelector.hs view
@@ -0,0 +1,2491 @@+{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor,+             RecordWildCards, NamedFieldPuns #-}+-- TODO+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.TargetSelector+-- Copyright   :  (c) Duncan Coutts 2012, 2015, 2016+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified target selectors.+--+-----------------------------------------------------------------------------+module Distribution.Client.TargetSelector (++    -- * Target selectors+    TargetSelector(..),+    TargetImplicitCwd(..),+    ComponentKind(..),+    ComponentKindFilter,+    SubComponentTarget(..),+    QualLevel(..),+    componentKind,++    -- * Reading target selectors+    readTargetSelectors,+    TargetSelectorProblem(..),+    reportTargetSelectorProblems,+    showTargetSelector,+    TargetString(..),+    showTargetString,+    parseTargetString,+    -- ** non-IO+    readTargetSelectorsWith,+    DirActions(..),+    defaultDirActions,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Package+         ( Package(..), PackageId, PackageName, packageName )+import Distribution.Types.UnqualComponentName+         ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName+         , packageNameToUnqualComponentName )+import Distribution.Client.Types+         ( PackageLocation(..), PackageSpecifier(..) )++import Distribution.PackageDescription+         ( PackageDescription+         , Executable(..)+         , TestSuite(..), TestSuiteInterface(..), testModules+         , Benchmark(..), BenchmarkInterface(..), benchmarkModules+         , BuildInfo(..), explicitLibModules, exeModules )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )+import Distribution.Solver.Types.SourcePackage+         ( SourcePackage(..) )+import Distribution.ModuleName+         ( ModuleName, toFilePath )+import Distribution.Simple.LocalBuildInfo+         ( Component(..), ComponentName(..), LibraryName(..)+         , pkgComponents, componentName, componentBuildInfo )+import Distribution.Types.ForeignLib++import Distribution.Simple.Utils+         ( die', lowercase, ordNub )+import Distribution.Client.Utils+         ( makeRelativeCanonical )++import Data.List+         ( stripPrefix, groupBy )+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Lazy   as Map.Lazy+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Control.Arrow ((&&&))+import Control.Monad+  hiding ( mfilter )+import qualified Distribution.Deprecated.ReadP as Parse+import Distribution.Deprecated.ReadP+         ( (+++), (<++) )+import Distribution.Deprecated.ParseUtils+         ( readPToMaybe )+import System.FilePath as FilePath+         ( takeExtension, dropExtension+         , splitDirectories, joinPath, splitPath )+import qualified System.Directory as IO+         ( doesFileExist, doesDirectoryExist, canonicalizePath+         , getCurrentDirectory )+import System.FilePath+         ( (</>), (<.>), normalise, dropTrailingPathSeparator )+import Text.EditDistance+         ( defaultEditCosts, restrictedDamerauLevenshteinDistance )+import Distribution.Utils.Path++import qualified Prelude (foldr1)++-- ------------------------------------------------------------+-- * Target selector terms+-- ------------------------------------------------------------++-- | A target selector is expression selecting a set of components (as targets+-- for a actions like @build@, @run@, @test@ etc). A target selector+-- corresponds to the user syntax for referring to targets on the command line.+--+-- From the users point of view a target can be many things: packages, dirs,+-- component names, files etc. Internally we consider a target to be a specific+-- component (or module\/file within a component), and all the users' notions+-- of targets are just different ways of referring to these component targets.+--+-- So target selectors are expressions in the sense that they are interpreted+-- to refer to one or more components. For example a 'TargetPackage' gets+-- interpreted differently by different commands to refer to all or a subset+-- of components within the package.+--+-- The syntax has lots of optional parts:+--+-- > [ package name | package dir | package .cabal file ]+-- > [ [lib:|exe:] component name ]+-- > [ module name | source file ]+--+data TargetSelector =++     -- | One (or more) packages as a whole, or all the components of a+     -- particular kind within the package(s).+     --+     -- These are always packages that are local to the project. In the case+     -- that there is more than one, they all share the same directory location.+     --+     TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter)++     -- | A package specified by name. This may refer to @extra-packages@ from+     -- the @cabal.project@ file, or a dependency of a known project package or+     -- could refer to a package from a hackage archive. It needs further+     -- context to resolve to a specific package.+     --+   | TargetPackageNamed PackageName (Maybe ComponentKindFilter)++     -- | All packages, or all components of a particular kind in all packages.+     --+   | TargetAllPackages (Maybe ComponentKindFilter)++     -- | A specific component in a package within the project.+     --+   | TargetComponent PackageId ComponentName SubComponentTarget++     -- | A component in a package, but where it cannot be verified that the+     -- package has such a component, or because the package is itself not+     -- known.+     --+   | TargetComponentUnknown PackageName+                            (Either UnqualComponentName ComponentName)+                            SubComponentTarget+  deriving (Eq, Ord, Show, Generic)++-- | Does this 'TargetPackage' selector arise from syntax referring to a+-- package in the current directory (e.g. @tests@ or no giving no explicit+-- target at all) or does it come from syntax referring to a package name+-- or location.+--+data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed+  deriving (Eq, Ord, Show, Generic)++data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind+  deriving (Eq, Ord, Enum, Show)++type ComponentKindFilter = ComponentKind++-- | Either the component as a whole or detail about a file or module target+-- within a component.+--+data SubComponentTarget =++     -- | The component as a whole+     WholeComponent++     -- | A specific module within a component.+   | ModuleTarget ModuleName++     -- | A specific file within a component. Note that this does not carry the+     -- file extension.+   | FileTarget   FilePath+  deriving (Eq, Ord, Show, Generic)++instance Binary SubComponentTarget+instance Structured SubComponentTarget+++-- ------------------------------------------------------------+-- * Top level, do everything+-- ------------------------------------------------------------+++-- | Parse a bunch of command line args as 'TargetSelector's, failing with an+-- error if any are unrecognised. The possible target selectors are based on+-- the available packages (and their locations).+--+readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]+                    -> Maybe ComponentKindFilter+                    -- ^ This parameter is used when there are ambiguous selectors.+                    --   If it is 'Just', then we attempt to resolve ambiguitiy+                    --   by applying it, since otherwise there is no way to allow+                    --   contextually valid yet syntactically ambiguous selectors.+                    --   (#4676, #5461)+                    -> [String]+                    -> IO (Either [TargetSelectorProblem] [TargetSelector])+readTargetSelectors = readTargetSelectorsWith defaultDirActions++readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m+                        -> [PackageSpecifier (SourcePackage (PackageLocation a))]+                        -> Maybe ComponentKindFilter+                        -> [String]+                        -> m (Either [TargetSelectorProblem] [TargetSelector])+readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs =+    case parseTargetStrings targetStrs of+      ([], usertargets) -> do+        usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets+        knowntargets <- getKnownTargets dirActions pkgs+        case resolveTargetSelectors knowntargets usertargets' mfilter of+          ([], btargets) -> return (Right btargets)+          (problems, _)  -> return (Left problems)+      (strs, _)          -> return (Left (map TargetSelectorUnrecognised strs))+++data DirActions m = DirActions {+       doesFileExist       :: FilePath -> m Bool,+       doesDirectoryExist  :: FilePath -> m Bool,+       canonicalizePath    :: FilePath -> m FilePath,+       getCurrentDirectory :: m FilePath+     }++defaultDirActions :: DirActions IO+defaultDirActions =+    DirActions {+      doesFileExist       = IO.doesFileExist,+      doesDirectoryExist  = IO.doesDirectoryExist,+      -- Workaround for <https://github.com/haskell/directory/issues/63>+      canonicalizePath    = IO.canonicalizePath . dropTrailingPathSeparator,+      getCurrentDirectory = IO.getCurrentDirectory+    }++makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath+makeRelativeToCwd DirActions{..} path =+    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory+++-- ------------------------------------------------------------+-- * Parsing target strings+-- ------------------------------------------------------------++-- | The outline parse of a target selector. It takes one of the forms:+--+-- > str1+-- > str1:str2+-- > str1:str2:str3+-- > str1:str2:str3:str4+--+data TargetString =+     TargetString1 String+   | TargetString2 String String+   | TargetString3 String String String+   | TargetString4 String String String String+   | TargetString5 String String String String String+   | TargetString7 String String String String String String String+  deriving (Show, Eq)++-- | Parse a bunch of 'TargetString's (purely without throwing exceptions).+--+parseTargetStrings :: [String] -> ([String], [TargetString])+parseTargetStrings =+    partitionEithers+  . map (\str -> maybe (Left str) Right (parseTargetString str))++parseTargetString :: String -> Maybe TargetString+parseTargetString =+    readPToMaybe parseTargetApprox+  where+    parseTargetApprox :: Parse.ReadP r TargetString+    parseTargetApprox =+          (do a <- tokenQ+              return (TargetString1 a))+      +++ (do a <- tokenQ0+              _ <- Parse.char ':'+              b <- tokenQ+              return (TargetString2 a b))+      +++ (do a <- tokenQ0+              _ <- Parse.char ':'+              b <- tokenQ+              _ <- Parse.char ':'+              c <- tokenQ+              return (TargetString3 a b c))+      +++ (do a <- tokenQ0+              _ <- Parse.char ':'+              b <- token+              _ <- Parse.char ':'+              c <- tokenQ+              _ <- Parse.char ':'+              d <- tokenQ+              return (TargetString4 a b c d))+      +++ (do a <- tokenQ0+              _ <- Parse.char ':'+              b <- token+              _ <- Parse.char ':'+              c <- tokenQ+              _ <- Parse.char ':'+              d <- tokenQ+              _ <- Parse.char ':'+              e <- tokenQ+              return (TargetString5 a b c d e))+      +++ (do a <- tokenQ0+              _ <- Parse.char ':'+              b <- token+              _ <- Parse.char ':'+              c <- tokenQ+              _ <- Parse.char ':'+              d <- tokenQ+              _ <- Parse.char ':'+              e <- tokenQ+              _ <- Parse.char ':'+              f <- tokenQ+              _ <- Parse.char ':'+              g <- tokenQ+              return (TargetString7 a b c d e f g))++    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')+    tokenQ = parseHaskellString <++ token+    token0 = Parse.munch (\x -> not (isSpace x) && x /= ':')+    tokenQ0= parseHaskellString <++ token0+    parseHaskellString :: Parse.ReadP r String+    parseHaskellString = Parse.readS_to_P reads+++-- | Render a 'TargetString' back as the external syntax. This is mainly for+-- error messages.+--+showTargetString :: TargetString -> String+showTargetString = intercalate ":" . components+  where+    components (TargetString1 s1)          = [s1]+    components (TargetString2 s1 s2)       = [s1,s2]+    components (TargetString3 s1 s2 s3)    = [s1,s2,s3]+    components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4]+    components (TargetString5 s1 s2 s3 s4 s5)       = [s1,s2,s3,s4,s5]+    components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7]++showTargetSelector :: TargetSelector -> String+showTargetSelector ts =+  case [ t | ql <- [QL1 .. QLFull]+           , t  <- renderTargetSelector ql ts ]+  of (t':_) -> showTargetString (forgetFileStatus t')+     [] -> ""++showTargetSelectorKind :: TargetSelector -> String+showTargetSelectorKind bt = case bt of+  TargetPackage TargetExplicitNamed _ Nothing  -> "package"+  TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter"+  TargetPackage TargetImplicitCwd   _ Nothing  -> "cwd-package"+  TargetPackage TargetImplicitCwd   _ (Just _) -> "cwd-package:filter"+  TargetPackageNamed                _ Nothing  -> "named-package"+  TargetPackageNamed                _ (Just _) -> "named-package:filter"+  TargetAllPackages Nothing                    -> "package *"+  TargetAllPackages (Just _)                   -> "package *:filter"+  TargetComponent        _ _ WholeComponent    -> "component"+  TargetComponent        _ _ ModuleTarget{}    -> "module"+  TargetComponent        _ _ FileTarget{}      -> "file"+  TargetComponentUnknown _ _ WholeComponent    -> "unknown-component"+  TargetComponentUnknown _ _ ModuleTarget{}    -> "unknown-module"+  TargetComponentUnknown _ _ FileTarget{}      -> "unknown-file"+++-- ------------------------------------------------------------+-- * Checking if targets exist as files+-- ------------------------------------------------------------++data TargetStringFileStatus =+     TargetStringFileStatus1 String FileStatus+   | TargetStringFileStatus2 String FileStatus String+   | TargetStringFileStatus3 String FileStatus String String+   | TargetStringFileStatus4 String String String String+   | TargetStringFileStatus5 String String String String String+   | TargetStringFileStatus7 String String String String String String String+  deriving (Eq, Ord, Show)++data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath+                | FileStatusExistsDir  FilePath -- the canonicalised filepath+                | FileStatusNotExists  Bool -- does the parent dir exist even?+  deriving (Eq, Ord, Show)++noFileStatus :: FileStatus+noFileStatus = FileStatusNotExists False++getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m+                          -> TargetString -> m TargetStringFileStatus+getTargetStringFileStatus DirActions{..} t =+    case t of+      TargetString1 s1 ->+        (\f1 -> TargetStringFileStatus1 s1 f1)          <$> fileStatus s1+      TargetString2 s1 s2 ->+        (\f1 -> TargetStringFileStatus2 s1 f1 s2)       <$> fileStatus s1+      TargetString3 s1 s2 s3 ->+        (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3)    <$> fileStatus s1+      TargetString4 s1 s2 s3 s4 ->+        return (TargetStringFileStatus4 s1 s2 s3 s4)+      TargetString5 s1 s2 s3 s4 s5 ->+        return (TargetStringFileStatus5 s1 s2 s3 s4 s5)+      TargetString7 s1 s2 s3 s4 s5 s6 s7 ->+        return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7)+  where+    fileStatus f = do+      fexists <- doesFileExist f+      dexists <- doesDirectoryExist f+      case splitPath f of+        _ | fexists -> FileStatusExistsFile <$> canonicalizePath f+          | dexists -> FileStatusExistsDir  <$> canonicalizePath f+        (d:_)       -> FileStatusNotExists  <$> doesDirectoryExist d+        _           -> pure (FileStatusNotExists False)++forgetFileStatus :: TargetStringFileStatus -> TargetString+forgetFileStatus t = case t of+    TargetStringFileStatus1 s1 _          -> TargetString1 s1+    TargetStringFileStatus2 s1 _ s2       -> TargetString2 s1 s2+    TargetStringFileStatus3 s1 _ s2 s3    -> TargetString3 s1 s2 s3+    TargetStringFileStatus4 s1   s2 s3 s4 -> TargetString4 s1 s2 s3 s4+    TargetStringFileStatus5 s1   s2 s3 s4+                                       s5 -> TargetString5 s1 s2 s3 s4 s5+    TargetStringFileStatus7 s1   s2 s3 s4+                                 s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7++getFileStatus :: TargetStringFileStatus -> Maybe FileStatus+getFileStatus (TargetStringFileStatus1 _ f)     = Just f+getFileStatus (TargetStringFileStatus2 _ f _)   = Just f+getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f+getFileStatus _                                 = Nothing++setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus+setFileStatus f (TargetStringFileStatus1 s1 _)       = TargetStringFileStatus1 s1 f+setFileStatus f (TargetStringFileStatus2 s1 _ s2)    = TargetStringFileStatus2 s1 f s2+setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3+setFileStatus _ t                                    = t++copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus+copyFileStatus src dst =+    case getFileStatus src of+      Just f -> setFileStatus f dst+      Nothing -> dst++-- ------------------------------------------------------------+-- * Resolving target strings to target selectors+-- ------------------------------------------------------------+++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to.+--+resolveTargetSelectors :: KnownTargets+                       -> [TargetStringFileStatus]+                       -> Maybe ComponentKindFilter+                       -> ([TargetSelectorProblem],+                           [TargetSelector])+-- default local dir target if there's no given target:+resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ =+    ([TargetSelectorNoTargetsInProject], [])++resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ =+    ([TargetSelectorNoTargetsInCwd], [])++resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ =+    ([], [TargetPackage TargetImplicitCwd pkgids Nothing])+  where+    pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ]++resolveTargetSelectors knowntargets targetStrs mfilter =+    partitionEithers+  . map (resolveTargetSelector knowntargets mfilter)+  $ targetStrs++resolveTargetSelector :: KnownTargets+                      -> Maybe ComponentKindFilter+                      -> TargetStringFileStatus+                      -> Either TargetSelectorProblem TargetSelector+resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =+    case findMatch (matcher targetStrStatus) of++      Unambiguous _+        | projectIsEmpty -> Left TargetSelectorNoTargetsInProject++      Unambiguous (TargetPackage TargetImplicitCwd [] _)+                         -> Left (TargetSelectorNoCurrentPackage targetStr)++      Unambiguous target -> Right target++      None errs+        | projectIsEmpty       -> Left TargetSelectorNoTargetsInProject+        | otherwise            -> Left (classifyMatchErrors errs)++      Ambiguous _          targets+        | Just kfilter <- mfilter+        , [target] <- applyKindFilter kfilter targets -> Right target++      Ambiguous exactMatch targets ->+        case disambiguateTargetSelectors+               matcher targetStrStatus exactMatch+               targets of+          Right targets'   -> Left (TargetSelectorAmbiguous targetStr targets')+          Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms)+          Left []          -> internalError "resolveTargetSelector"+  where+    matcher = matchTargetSelector knowntargets++    targetStr = forgetFileStatus targetStrStatus++    projectIsEmpty = null knownPackagesAll++    classifyMatchErrors errs+      | Just expectedNE <- NE.nonEmpty expected+      = let (things, got:|_) = NE.unzip expectedNE in+        TargetSelectorExpected targetStr (NE.toList things) got++      | not (null nosuch)+      = TargetSelectorNoSuch targetStr nosuch++      | otherwise+      = internalError $ "classifyMatchErrors: " ++ show errs+      where+        expected = [ (thing, got)+                   | (_, MatchErrorExpected thing got)+                           <- map (innerErr Nothing) errs ]+        -- Trim the list of alternatives by dropping duplicates and+        -- retaining only at most three most similar (by edit distance) ones.+        nosuch   = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $+          [ ((inside, thing, got), Set.fromList alts)+          | (inside, MatchErrorNoSuch thing got alts)+            <- map (innerErr Nothing) errs+          ]++        genResults (inside, thing, got) alts acc = (+            inside+          , thing+          , got+          , take maxResults+            $ map fst+            $ takeWhile distanceLow+            $ sortBy (comparing snd)+            $ map addLevDist+            $ Set.toList alts+          ) : acc+          where+            addLevDist = id &&& restrictedDamerauLevenshteinDistance+                                defaultEditCosts got++            distanceLow (_, dist) = dist < length got `div` 2++            maxResults = 3++        innerErr _ (MatchErrorIn kind thing m)+                     = innerErr (Just (kind,thing)) m+        innerErr c m = (c,m)++    applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector]+    applyKindFilter kfilter = filter go+      where+        go (TargetPackage      _ _ (Just filter')) = kfilter == filter'+        go (TargetPackageNamed _   (Just filter')) = kfilter == filter'+        go (TargetAllPackages      (Just filter')) = kfilter == filter'+        go (TargetComponent _ cname _)+          | CLibName    _ <- cname                 = kfilter == LibKind+          | CFLibName   _ <- cname                 = kfilter == FLibKind+          | CExeName    _ <- cname                 = kfilter == ExeKind+          | CTestName   _ <- cname                 = kfilter == TestKind+          | CBenchName  _ <- cname                 = kfilter == BenchKind+        go _                                       = True++-- | The various ways that trying to resolve a 'TargetString' to a+-- 'TargetSelector' can fail.+--+data TargetSelectorProblem+   = TargetSelectorExpected TargetString [String]  String+     -- ^  [expected thing] (actually got)+   | TargetSelectorNoSuch  TargetString+                           [(Maybe (String, String), String, String, [String])]+     -- ^ [([in thing], no such thing,  actually got, alternatives)]+   | TargetSelectorAmbiguous  TargetString+                              [(TargetString, TargetSelector)]++   | MatchingInternalError TargetString TargetSelector+                           [(TargetString, [TargetSelector])]+   | TargetSelectorUnrecognised String+     -- ^ Syntax error when trying to parse a target string.+   | TargetSelectorNoCurrentPackage TargetString+   | TargetSelectorNoTargetsInCwd+   | TargetSelectorNoTargetsInProject+  deriving (Show, Eq)++-- | Qualification levels.+-- Given the filepath src/F, executable component A, and package foo:+data QualLevel = QL1    -- ^ @src/F@+               | QL2    -- ^ @foo:src/F | A:src/F@+               | QL3    -- ^ @foo:A:src/F | exe:A:src/F@+               | QLFull -- ^ @pkg:foo:exe:A:file:src/F@+  deriving (Eq, Enum, Show)++disambiguateTargetSelectors+  :: (TargetStringFileStatus -> Match TargetSelector)+  -> TargetStringFileStatus -> MatchClass+  -> [TargetSelector]+  -> Either [(TargetSelector, [(TargetString, [TargetSelector])])]+            [(TargetString, TargetSelector)]+disambiguateTargetSelectors matcher matchInput exactMatch matchResults =+    case partitionEithers results of+      (errs@(_:_), _) -> Left errs+      ([], ok)        -> Right ok+  where+    -- So, here's the strategy. We take the original match results, and make a+    -- table of all their renderings at all qualification levels.+    -- Note there can be multiple renderings at each qualification level.++    -- Note that renderTargetSelector won't immediately work on any file syntax+    -- When rendering syntax, the FileStatus is always FileStatusNotExists,+    -- which will never match on syntaxForm1File!+    -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile.+    -- So we need to copy over the file status from the input+    -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus+    matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])]+    matchResultsRenderings =+      [ (matchResult, matchRenderings)+      | matchResult <- matchResults+      , let matchRenderings =+              [ copyFileStatus matchInput rendering+              | ql <- [QL1 .. QLFull]+              , rendering <- renderTargetSelector ql matchResult ]+      ]++    -- Of course the point is that we're looking for renderings that are+    -- unambiguous matches. So we build another memo table of all the matches+    -- for all of those renderings. So by looking up in this table we can see+    -- if we've got an unambiguous match.++    memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector)+    memoisedMatches =+        -- avoid recomputing the main one if it was an exact match+        (if exactMatch == Exact+           then Map.insert matchInput (Match Exact 0 matchResults)+           else id)+      $ Map.Lazy.fromList+        -- (matcher rendering) should *always* be a Match! Otherwise we will hit+        -- the internal error later on.+          [ (rendering, matcher rendering)+          | rendering <- concatMap snd matchResultsRenderings ]++    -- Finally, for each of the match results, we go through all their+    -- possible renderings (in order of qualification level, though remember+    -- there can be multiple renderings per level), and find the first one+    -- that has an unambiguous match.+    results :: [Either (TargetSelector, [(TargetString, [TargetSelector])])+                       (TargetString, TargetSelector)]+    results =+      [ case findUnambiguous originalMatch matchRenderings of+          Just unambiguousRendering ->+            Right ( forgetFileStatus unambiguousRendering+                  , originalMatch)++          -- This case is an internal error, but we bubble it up and report it+          Nothing ->+            Left  ( originalMatch+                  , [ (forgetFileStatus rendering, matches)+                    | rendering <- matchRenderings+                    , let Match m _ matches =+                            memoisedMatches Map.! rendering+                    , m /= Inexact+                    ] )++      | (originalMatch, matchRenderings) <- matchResultsRenderings ]++    findUnambiguous :: TargetSelector+                    -> [TargetStringFileStatus]+                    -> Maybe TargetStringFileStatus+    findUnambiguous _ []     = Nothing+    findUnambiguous t (r:rs) =+      case memoisedMatches Map.! r of+        Match Exact _ [t'] | t == t'+                          -> Just r+        Match Exact   _ _ -> findUnambiguous t rs+        Match Unknown _ _ -> findUnambiguous t rs+        Match Inexact _ _ -> internalError "Match Inexact"+        NoMatch       _ _ -> internalError "NoMatch"++internalError :: String -> a+internalError msg =+  error $ "TargetSelector: internal error: " ++ msg+++-- | Throw an exception with a formatted message if there are any problems.+--+reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a+reportTargetSelectorProblems verbosity problems = do++    case [ str | TargetSelectorUnrecognised str <- problems ] of+      []      -> return ()+      targets ->+        die' verbosity $ unlines+          [ "Unrecognised target syntax for '" ++ name ++ "'."+          | name <- targets ]++    case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of+      [] -> return ()+      ((target, originalMatch, renderingsAndMatches):_) ->+        die' verbosity $ "Internal error in target matching. It should always "+           ++ "be possible to find a syntax that's sufficiently qualified to "+           ++ "give an unambiguous match. However when matching '"+           ++ showTargetString target ++ "'  we found "+           ++ showTargetSelector originalMatch+           ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does "+           ++ "not have an unambiguous syntax. The possible syntax and the "+           ++ "targets they match are as follows:\n"+           ++ unlines+                [ "'" ++ showTargetString rendering ++ "' which matches "+                  ++ intercalate ", "+                       [ showTargetSelector match +++                         " (" ++ showTargetSelectorKind match ++ ")"+                       | match <- matches ]+                | (rendering, matches) <- renderingsAndMatches ]++    case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of+      []      -> return ()+      targets ->+        die' verbosity $ unlines+          [    "Unrecognised target '" ++ showTargetString target+            ++ "'.\n"+            ++ "Expected a " ++ intercalate " or " expected+            ++ ", rather than '" ++ got ++ "'."+          | (target, expected, got) <- targets ]++    case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of+      []      -> return ()+      targets ->+        die' verbosity $ unlines+          [ "Unknown target '" ++ showTargetString target +++            "'.\n" ++ unlines+            [    (case inside of+                    Just (kind, "")+                            -> "The " ++ kind ++ " has no "+                    Just (kind, thing)+                            -> "The " ++ kind ++ " " ++ thing ++ " has no "+                    Nothing -> "There is no ")+              ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"+                                    | (thing, got, _alts) <- nosuch' ] ++ "."+              ++ if null alternatives then "" else+                 "\nPerhaps you meant " ++ intercalate ";\nor "+                 [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?"+                 | (thing, alts) <- alternatives ]+            | (inside, nosuch') <- groupByContainer nosuch+            , let alternatives =+                    [ (thing, alts)+                    | (thing,_got,alts@(_:_)) <- nosuch' ]+            ]+          | (target, nosuch) <- targets+          , let groupByContainer =+                    map (\g@((inside,_,_,_):_) ->+                            (inside, [   (thing,got,alts)+                                     | (_,thing,got,alts) <- g ]))+                  . groupBy ((==)    `on` (\(x,_,_,_) -> x))+                  . sortBy  (compare `on` (\(x,_,_,_) -> x))+          ]+        where+          mungeThing "file" = "file target"+          mungeThing thing  = thing++    case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of+      []      -> return ()+      targets ->+        die' verbosity $ unlines+          [    "Ambiguous target '" ++ showTargetString target+            ++ "'. It could be:\n "+            ++ unlines [ "   "++ showTargetString ut +++                         " (" ++ showTargetSelectorKind bt ++ ")"+                       | (ut, bt) <- amb ]+          | (target, amb) <- targets ]++    case [ t | TargetSelectorNoCurrentPackage t <- problems ] of+      []       -> return ()+      target:_ ->+        die' verbosity $+            "The target '" ++ showTargetString target ++ "' refers to the "+         ++ "components in the package in the current directory, but there "+         ++ "is no package in the current directory (or at least not listed "+         ++ "as part of the project)."+        --TODO: report a different error if there is a .cabal file but it's+        -- not a member of the project++    case [ () | TargetSelectorNoTargetsInCwd <- problems ] of+      []  -> return ()+      _:_ ->+        die' verbosity $+            "No targets given and there is no package in the current "+         ++ "directory. Use the target 'all' for all packages in the "+         ++ "project or specify packages or components by name or location. "+         ++ "See 'cabal build --help' for more details on target options."++    case [ () | TargetSelectorNoTargetsInProject <- problems ] of+      []  -> return ()+      _:_ ->+        die' verbosity $+            "There is no <pkgname>.cabal package file or cabal.project file. "+         ++ "To build packages locally you need at minimum a <pkgname>.cabal "+         ++ "file. You can use 'cabal init' to create one.\n"+         ++ "\n"+         ++ "For non-trivial projects you will also want a cabal.project "+         ++ "file in the root directory of your project. This file lists the "+         ++ "packages in your project and all other build configuration. "+         ++ "See the Cabal user guide for full details."++    fail "reportTargetSelectorProblems: internal error"+++----------------------------------+-- Syntax type+--++-- | Syntax for the 'TargetSelector': the matcher and renderer+--+data Syntax = Syntax QualLevel Matcher Renderer+            | AmbiguousAlternatives Syntax Syntax+            | ShadowingAlternatives Syntax Syntax++type Matcher  = TargetStringFileStatus -> Match TargetSelector+type Renderer = TargetSelector -> [TargetStringFileStatus]++foldSyntax :: (a -> a -> a) -> (a -> a -> a)+           -> (QualLevel -> Matcher -> Renderer -> a)+           -> (Syntax -> a)+foldSyntax ambiguous unambiguous syntax = go+  where+    go (Syntax ql match render)    = syntax ql match render+    go (AmbiguousAlternatives a b) = ambiguous   (go a) (go b)+    go (ShadowingAlternatives a b) = unambiguous (go a) (go b)+++----------------------------------+-- Top level renderer and matcher+--++renderTargetSelector :: QualLevel -> TargetSelector+                     -> [TargetStringFileStatus]+renderTargetSelector ql ts =+    foldSyntax+      (++) (++)+      (\ql' _ render -> guard (ql == ql') >> render ts)+      syntax+  where+    syntax = syntaxForms emptyKnownTargets+                         -- don't need known targets for rendering++matchTargetSelector :: KnownTargets+                    -> TargetStringFileStatus+                    -> Match TargetSelector+matchTargetSelector knowntargets = \usertarget ->+    nubMatchesBy (==) $++    let ql = targetQualLevel usertarget in+    foldSyntax+      (<|>) (<//>)+      (\ql' match _ -> guard (ql == ql') >> match usertarget)+      syntax+  where+    syntax = syntaxForms knowntargets++    targetQualLevel TargetStringFileStatus1{} = QL1+    targetQualLevel TargetStringFileStatus2{} = QL2+    targetQualLevel TargetStringFileStatus3{} = QL3+    targetQualLevel TargetStringFileStatus4{} = QLFull+    targetQualLevel TargetStringFileStatus5{} = QLFull+    targetQualLevel TargetStringFileStatus7{} = QLFull+++----------------------------------+-- Syntax forms+--++-- | All the forms of syntax for 'TargetSelector'.+--+syntaxForms :: KnownTargets -> Syntax+syntaxForms KnownTargets {+              knownPackagesAll       = pinfo,+              knownPackagesPrimary   = ppinfo,+              knownComponentsAll     = cinfo,+              knownComponentsPrimary = pcinfo,+              knownComponentsOther   = ocinfo+            } =+    -- The various forms of syntax here are ambiguous in many cases.+    -- Our policy is by default we expose that ambiguity and report+    -- ambiguous matches. In certain cases we override the ambiguity+    -- by having some forms shadow others.+    --+    -- We make modules shadow files because module name "Q" clashes+    -- with file "Q" with no extension but these refer to the same+    -- thing anyway so it's not a useful ambiguity. Other cases are+    -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q".++    ambiguousAlternatives+        -- convenient single-component forms+      [ shadowingAlternatives+          [ ambiguousAlternatives+              [ syntaxForm1All+              , syntaxForm1Filter        ppinfo+              , shadowingAlternatives+                  [ syntaxForm1Component pcinfo+                  , syntaxForm1Package   pinfo+                  ]+              ]+          , syntaxForm1Component ocinfo+          , syntaxForm1Module    cinfo+          , syntaxForm1File      pinfo+          ]++        -- two-component partially qualified forms+        -- fully qualified form for 'all'+      , syntaxForm2MetaAll+      , syntaxForm2AllFilter+      , syntaxForm2NamespacePackage pinfo+      , syntaxForm2PackageComponent pinfo+      , syntaxForm2PackageFilter    pinfo+      , syntaxForm2KindComponent    cinfo+      , shadowingAlternatives+          [ syntaxForm2PackageModule   pinfo+          , syntaxForm2PackageFile     pinfo+          ]+      , shadowingAlternatives+          [ syntaxForm2ComponentModule cinfo+          , syntaxForm2ComponentFile   cinfo+          ]++        -- rarely used partially qualified forms+      , syntaxForm3PackageKindComponent   pinfo+      , shadowingAlternatives+          [ syntaxForm3PackageComponentModule pinfo+          , syntaxForm3PackageComponentFile   pinfo+          ]+      , shadowingAlternatives+          [ syntaxForm3KindComponentModule    cinfo+          , syntaxForm3KindComponentFile      cinfo+          ]+      , syntaxForm3NamespacePackageFilter pinfo++        -- fully-qualified forms for all and cwd with filter+      , syntaxForm3MetaAllFilter+      , syntaxForm3MetaCwdFilter ppinfo++        -- fully-qualified form for package and package with filter+      , syntaxForm3MetaNamespacePackage       pinfo+      , syntaxForm4MetaNamespacePackageFilter pinfo++        -- fully-qualified forms for component, module and file+      , syntaxForm5MetaNamespacePackageKindComponent                pinfo+      , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo+      , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile   pinfo+      ]+  where+    ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives+    shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives+++-- | Syntax: "all" to select all packages in the project+--+-- > cabal build all+--+syntaxForm1All :: Syntax+syntaxForm1All =+  syntaxForm1 render $ \str1 _fstatus1 -> do+    guardMetaAll str1+    return (TargetAllPackages Nothing)+  where+    render (TargetAllPackages Nothing) =+      [TargetStringFileStatus1 "all" noFileStatus]+    render _ = []++-- | Syntax: filter+--+-- > cabal build tests+--+syntaxForm1Filter :: [KnownPackage] -> Syntax+syntaxForm1Filter ps =+  syntaxForm1 render $ \str1 _fstatus1 -> do+    kfilter <- matchComponentKindFilter str1+    return (TargetPackage TargetImplicitCwd pids (Just kfilter))+  where+    pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]+    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =+      [TargetStringFileStatus1 (dispF kfilter) noFileStatus]+    render _ = []+++-- | Syntax: package (name, dir or file)+--+-- > cabal build foo+-- > cabal build ../bar ../bar/bar.cabal+--+syntaxForm1Package :: [KnownPackage] -> Syntax+syntaxForm1Package pinfo =+  syntaxForm1 render $ \str1 fstatus1 -> do+    guardPackage            str1 fstatus1+    p <- matchPackage pinfo str1 fstatus1+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)+      KnownPackageName pn ->+        return (TargetPackageNamed pn Nothing)+  where+    render (TargetPackage TargetExplicitNamed [p] Nothing) =+      [TargetStringFileStatus1 (dispP p) noFileStatus]+    render (TargetPackageNamed pn Nothing) =+      [TargetStringFileStatus1 (dispPN pn) noFileStatus]+    render _ = []++-- | Syntax: component+--+-- > cabal build foo+--+syntaxForm1Component :: [KnownComponent] -> Syntax+syntaxForm1Component cs =+  syntaxForm1 render $ \str1 _fstatus1 -> do+    guardComponentName str1+    c <- matchComponentName cs str1+    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus1 (dispC p c) noFileStatus]+    render _ = []++-- | Syntax: module+--+-- > cabal build Data.Foo+--+syntaxForm1Module :: [KnownComponent] -> Syntax+syntaxForm1Module cs =+  syntaxForm1 render $  \str1 _fstatus1 -> do+    guardModuleName str1+    let ms = [ (m,c) | c <- cs, m <- cinfoModules c ]+    (m,c) <- matchModuleNameAnd ms str1+    return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m))+  where+    render (TargetComponent _p _c (ModuleTarget m)) =+      [TargetStringFileStatus1 (dispM m) noFileStatus]+    render _ = []++-- | Syntax: file name+--+-- > cabal build Data/Foo.hs bar/Main.hsc+--+syntaxForm1File :: [KnownPackage] -> Syntax+syntaxForm1File ps =+    -- Note there's a bit of an inconsistency here vs the other syntax forms+    -- for files. For the single-part syntax the target has to point to a file+    -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for+    -- all the other forms we don't require that.+  syntaxForm1 render $ \str1 fstatus1 ->+    expecting "file" str1 $ do+    (pkgfile, ~KnownPackage{pinfoId, pinfoComponents})+      -- always returns the KnownPackage case+      <- matchPackageDirectoryPrefix ps fstatus1+    orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+      (filepath, c) <- matchComponentFile pinfoComponents pkgfile+      return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+  where+    render (TargetComponent _p _c (FileTarget f)) =+      [TargetStringFileStatus1 f noFileStatus]+    render _ = []++---++-- | Syntax:  :all+--+-- > cabal build :all+--+syntaxForm2MetaAll :: Syntax+syntaxForm2MetaAll =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    guardNamespaceMeta str1+    guardMetaAll str2+    return (TargetAllPackages Nothing)+  where+    render (TargetAllPackages Nothing) =+      [TargetStringFileStatus2 "" noFileStatus "all"]+    render _ = []++-- | Syntax:  all : filer+--+-- > cabal build all:tests+--+syntaxForm2AllFilter :: Syntax+syntaxForm2AllFilter =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    guardMetaAll str1+    kfilter <- matchComponentKindFilter str2+    return (TargetAllPackages (Just kfilter))+  where+    render (TargetAllPackages (Just kfilter)) =+      [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)]+    render _ = []++-- | Syntax:  package : filer+--+-- > cabal build foo:tests+--+syntaxForm2PackageFilter :: [KnownPackage] -> Syntax+syntaxForm2PackageFilter ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    p <- matchPackage ps str1 fstatus1+    kfilter <- matchComponentKindFilter str2+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))+      KnownPackageName pn ->+        return (TargetPackageNamed pn (Just kfilter))+  where+    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =+      [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)]+    render (TargetPackageNamed pn (Just kfilter)) =+      [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)]+    render _ = []++-- | Syntax: pkg : package name+--+-- > cabal build pkg:foo+--+syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax+syntaxForm2NamespacePackage pinfo =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    guardNamespacePackage   str1+    guardPackageName        str2+    p <- matchPackage pinfo str2 noFileStatus+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)+      KnownPackageName pn ->+        return (TargetPackageNamed pn Nothing)+  where+    render (TargetPackage TargetExplicitNamed [p] Nothing) =+      [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)]+    render (TargetPackageNamed pn Nothing) =+      [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)]+    render _ = []++-- | Syntax: package : component+--+-- > cabal build foo:foo+-- > cabal build ./foo:foo+-- > cabal build ./foo.cabal:foo+--+syntaxForm2PackageComponent :: [KnownPackage] -> Syntax+syntaxForm2PackageComponent ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    guardComponentName   str2+    p <- matchPackage ps str1 fstatus1+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentName pinfoComponents str2+          return (TargetComponent pinfoId (cinfoName c) WholeComponent)+        --TODO: the error here ought to say there's no component by that name in+        -- this package, and name the package+      KnownPackageName pn ->+        let cn = mkUnqualComponentName str2 in+        return (TargetComponentUnknown pn (Left cn) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]+    render (TargetComponentUnknown pn (Left cn) WholeComponent) =+      [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)]+    render _ = []++-- | Syntax: namespace : component+--+-- > cabal build lib:foo exe:foo+--+syntaxForm2KindComponent :: [KnownComponent] -> Syntax+syntaxForm2KindComponent cs =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)]+    render _ = []++-- | Syntax: package : module+--+-- > cabal build foo:Data.Foo+-- > cabal build ./foo:Data.Foo+-- > cabal build ./foo.cabal:Data.Foo+--+syntaxForm2PackageModule :: [KnownPackage] -> Syntax+syntaxForm2PackageModule ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    guardModuleName      str2+    p <- matchPackage ps str1 fstatus1+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ]+          (m,c) <- matchModuleNameAnd ms str2+          return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))+      KnownPackageName pn -> do+        m <- matchModuleNameUnknown str2+        -- We assume the primary library component of the package:+        return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m))+  where+    render (TargetComponent p _c (ModuleTarget m)) =+      [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)]+    render _ = []++-- | Syntax: component : module+--+-- > cabal build foo:Data.Foo+--+syntaxForm2ComponentModule :: [KnownComponent] -> Syntax+syntaxForm2ComponentModule cs =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    guardComponentName str1+    guardModuleName    str2+    c <- matchComponentName cs str1+    orNoThingIn "component" (cinfoStrName c) $ do+      let ms = cinfoModules c+      m <- matchModuleName ms str2+      return (TargetComponent (cinfoPackageId c) (cinfoName c)+                              (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)]+    render _ = []++-- | Syntax: package : filename+--+-- > cabal build foo:Data/Foo.hs+-- > cabal build ./foo:Data/Foo.hs+-- > cabal build ./foo.cabal:Data/Foo.hs+--+syntaxForm2PackageFile :: [KnownPackage] -> Syntax+syntaxForm2PackageFile ps =+  syntaxForm2 render $ \str1 fstatus1 str2 -> do+    guardPackage         str1 fstatus1+    p <- matchPackage ps str1 fstatus1+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          (filepath, c) <- matchComponentFile pinfoComponents str2+          return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+      KnownPackageName pn ->+        let filepath = str2 in+        -- We assume the primary library component of the package:+        return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath))+  where+    render (TargetComponent p _c (FileTarget f)) =+      [TargetStringFileStatus2 (dispP p) noFileStatus f]+    render _ = []++-- | Syntax: component : filename+--+-- > cabal build foo:Data/Foo.hs+--+syntaxForm2ComponentFile :: [KnownComponent] -> Syntax+syntaxForm2ComponentFile cs =+  syntaxForm2 render $ \str1 _fstatus1 str2 -> do+    guardComponentName str1+    c <- matchComponentName cs str1+    orNoThingIn "component" (cinfoStrName c) $ do+      (filepath, _) <- matchComponentFile [c] str2+      return (TargetComponent (cinfoPackageId c) (cinfoName c)+                              (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus2 (dispC p c) noFileStatus f]+    render _ = []++---++-- | Syntax: :all : filter+--+-- > cabal build :all:tests+--+syntaxForm3MetaAllFilter :: Syntax+syntaxForm3MetaAllFilter =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespaceMeta str1+    guardMetaAll str2+    kfilter <- matchComponentKindFilter str3+    return (TargetAllPackages (Just kfilter))+  where+    render (TargetAllPackages (Just kfilter)) =+      [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)]+    render _ = []++syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax+syntaxForm3MetaCwdFilter ps =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespaceMeta str1+    guardNamespaceCwd str2+    kfilter <- matchComponentKindFilter str3+    return (TargetPackage TargetImplicitCwd pids (Just kfilter))+  where+    pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]+    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =+      [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]+    render _ = []++-- | Syntax: :pkg : package name+--+-- > cabal build :pkg:foo+--+syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax+syntaxForm3MetaNamespacePackage pinfo =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespaceMeta      str1+    guardNamespacePackage   str2+    guardPackageName        str3+    p <- matchPackage pinfo str3 noFileStatus+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)+      KnownPackageName pn ->+        return (TargetPackageNamed pn Nothing)+  where+    render (TargetPackage TargetExplicitNamed [p] Nothing) =+      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)]+    render (TargetPackageNamed pn Nothing) =+      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)]+    render _ = []++-- | Syntax: package : namespace : component+--+-- > cabal build foo:lib:foo+-- > cabal build foo/:lib:foo+-- > cabal build foo.cabal:lib:foo+--+syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax+syntaxForm3PackageKindComponent ps =+  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do+    guardPackage         str1 fstatus1+    ckind <- matchComponentKind str2+    guardComponentName   str3+    p <- matchPackage ps str1 fstatus1+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str3+          return (TargetComponent pinfoId (cinfoName c) WholeComponent)+      KnownPackageName pn ->+        let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in+        return (TargetComponentUnknown pn (Right cn) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)]+    render (TargetComponentUnknown pn (Right c) WholeComponent) =+      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)]+    render _ = []++-- | Syntax: package : component : module+--+-- > cabal build foo:foo:Data.Foo+-- > cabal build foo/:foo:Data.Foo+-- > cabal build foo.cabal:foo:Data.Foo+--+syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax+syntaxForm3PackageComponentModule ps =+  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do+    guardPackage str1 fstatus1+    guardComponentName str2+    guardModuleName    str3+    p <- matchPackage ps str1 fstatus1+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentName pinfoComponents str2+          orNoThingIn "component" (cinfoStrName c) $ do+            let ms = cinfoModules c+            m <- matchModuleName ms str3+            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))+      KnownPackageName pn -> do+        let cn = mkUnqualComponentName  str2+        m     <- matchModuleNameUnknown str3+        return (TargetComponentUnknown pn (Left cn) (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)]+    render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) =+      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)]+    render _ = []++-- | Syntax: namespace : component : module+--+-- > cabal build lib:foo:Data.Foo+--+syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax+syntaxForm3KindComponentModule cs =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    guardModuleName    str3+    c <- matchComponentKindAndName cs ckind str2+    orNoThingIn "component" (cinfoStrName c) $ do+      let ms = cinfoModules c+      m <- matchModuleName ms str3+      return (TargetComponent (cinfoPackageId c) (cinfoName c)+                              (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)]+    render _ = []++-- | Syntax: package : component : filename+--+-- > cabal build foo:foo:Data/Foo.hs+-- > cabal build foo/:foo:Data/Foo.hs+-- > cabal build foo.cabal:foo:Data/Foo.hs+--+syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax+syntaxForm3PackageComponentFile ps =+  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do+    guardPackage         str1 fstatus1+    guardComponentName   str2+    p <- matchPackage ps str1 fstatus1+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentName pinfoComponents str2+          orNoThingIn "component" (cinfoStrName c) $ do+            (filepath, _) <- matchComponentFile [c] str3+            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+      KnownPackageName pn ->+        let cn = mkUnqualComponentName str2+            filepath = str3 in+        return (TargetComponentUnknown pn (Left cn) (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f]+    render (TargetComponentUnknown pn (Left c) (FileTarget f)) =+      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f]+    render _ = []++-- | Syntax: namespace : component : filename+--+-- > cabal build lib:foo:Data/Foo.hs+--+syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax+syntaxForm3KindComponentFile cs =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    orNoThingIn "component" (cinfoStrName c) $ do+      (filepath, _) <- matchComponentFile [c] str3+      return (TargetComponent (cinfoPackageId c) (cinfoName c)+                              (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f]+    render _ = []++syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax+syntaxForm3NamespacePackageFilter ps =+  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do+    guardNamespacePackage str1+    guardPackageName      str2+    p <- matchPackage  ps str2 noFileStatus+    kfilter <- matchComponentKindFilter str3+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))+      KnownPackageName pn ->+        return (TargetPackageNamed pn (Just kfilter))+  where+    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =+      [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)]+    render (TargetPackageNamed pn (Just kfilter)) =+      [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)]+    render _ = []++--++syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax+syntaxForm4MetaNamespacePackageFilter ps =+  syntaxForm4 render $ \str1 str2 str3 str4 -> do+    guardNamespaceMeta    str1+    guardNamespacePackage str2+    guardPackageName      str3+    p <- matchPackage  ps str3 noFileStatus+    kfilter <- matchComponentKindFilter str4+    case p of+      KnownPackage{pinfoId} ->+        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))+      KnownPackageName pn ->+        return (TargetPackageNamed pn (Just kfilter))+  where+    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =+      [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)]+    render (TargetPackageNamed pn (Just kfilter)) =+      [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)]+    render _ = []++-- | Syntax: :pkg : package : namespace : component+--+-- > cabal build :pkg:foo:lib:foo+--+syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax+syntaxForm5MetaNamespacePackageKindComponent ps =+  syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do+    guardNamespaceMeta    str1+    guardNamespacePackage str2+    guardPackageName      str3+    ckind <- matchComponentKind str4+    guardComponentName    str5+    p <- matchPackage  ps str3 noFileStatus+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str5+          return (TargetComponent pinfoId (cinfoName c) WholeComponent)+      KnownPackageName pn ->+        let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in+        return (TargetComponentUnknown pn (Right cn) WholeComponent)+  where+    render (TargetComponent p c WholeComponent) =+      [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)]+    render (TargetComponentUnknown pn (Right c) WholeComponent) =+      [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)]+    render _ = []++-- | Syntax: :pkg : package : namespace : component : module : module+--+-- > cabal build :pkg:foo:lib:foo:module:Data.Foo+--+syntaxForm7MetaNamespacePackageKindComponentNamespaceModule+  :: [KnownPackage] -> Syntax+syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps =+  syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do+    guardNamespaceMeta    str1+    guardNamespacePackage str2+    guardPackageName      str3+    ckind <- matchComponentKind str4+    guardComponentName    str5+    guardNamespaceModule  str6+    p <- matchPackage  ps str3 noFileStatus+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str5+          orNoThingIn "component" (cinfoStrName c) $ do+            let ms = cinfoModules c+            m <- matchModuleName ms str7+            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))+      KnownPackageName pn -> do+        let cn = mkComponentName pn ckind (mkUnqualComponentName str2)+        m <- matchModuleNameUnknown str7+        return (TargetComponentUnknown pn (Right cn) (ModuleTarget m))+  where+    render (TargetComponent p c (ModuleTarget m)) =+      [TargetStringFileStatus7 "" "pkg" (dispP p)+                               (dispCK c) (dispC p c)+                               "module" (dispM m)]+    render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) =+      [TargetStringFileStatus7 "" "pkg" (dispPN pn)+                               (dispCK c) (dispC' pn c)+                               "module" (dispM m)]+    render _ = []++-- | Syntax: :pkg : package : namespace : component : file : filename+--+-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs+--+syntaxForm7MetaNamespacePackageKindComponentNamespaceFile+  :: [KnownPackage] -> Syntax+syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps =+  syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do+    guardNamespaceMeta    str1+    guardNamespacePackage str2+    guardPackageName      str3+    ckind <- matchComponentKind str4+    guardComponentName    str5+    guardNamespaceFile    str6+    p <- matchPackage  ps str3 noFileStatus+    case p of+      KnownPackage{pinfoId, pinfoComponents} ->+        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do+          c <- matchComponentKindAndName pinfoComponents ckind str5+          orNoThingIn "component" (cinfoStrName c) $ do+            (filepath,_) <- matchComponentFile [c] str7+            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))+      KnownPackageName pn ->+        let cn       = mkComponentName pn ckind (mkUnqualComponentName str5)+            filepath = str7 in+        return (TargetComponentUnknown pn (Right cn) (FileTarget filepath))+  where+    render (TargetComponent p c (FileTarget f)) =+      [TargetStringFileStatus7 "" "pkg" (dispP p)+                               (dispCK c) (dispC p c)+                               "file" f]+    render (TargetComponentUnknown pn (Right c) (FileTarget f)) =+      [TargetStringFileStatus7 "" "pkg" (dispPN pn)+                               (dispCK c) (dispC' pn c)+                               "file" f]+    render _ = []+++---------------------------------------+-- Syntax utils+--++type Match1 = String -> FileStatus -> Match TargetSelector+type Match2 = String -> FileStatus -> String+              -> Match TargetSelector+type Match3 = String -> FileStatus -> String -> String+              -> Match TargetSelector+type Match4 = String -> String -> String -> String+              -> Match TargetSelector+type Match5 = String -> String -> String -> String -> String+              -> Match TargetSelector+type Match7 = String -> String -> String -> String -> String -> String -> String+              -> Match TargetSelector++syntaxForm1 :: Renderer -> Match1 -> Syntax+syntaxForm2 :: Renderer -> Match2 -> Syntax+syntaxForm3 :: Renderer -> Match3 -> Syntax+syntaxForm4 :: Renderer -> Match4 -> Syntax+syntaxForm5 :: Renderer -> Match5 -> Syntax+syntaxForm7 :: Renderer -> Match7 -> Syntax++syntaxForm1 render f =+    Syntax QL1 match render+  where+    match = \(TargetStringFileStatus1 str1 fstatus1) ->+              f str1 fstatus1++syntaxForm2 render f =+    Syntax QL2 match render+  where+    match = \(TargetStringFileStatus2 str1 fstatus1 str2) ->+              f str1 fstatus1 str2++syntaxForm3 render f =+    Syntax QL3 match render+  where+    match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) ->+              f str1 fstatus1 str2 str3++syntaxForm4 render f =+    Syntax QLFull match render+  where+    match (TargetStringFileStatus4 str1 str2 str3 str4)+            = f str1 str2 str3 str4+    match _ = mzero++syntaxForm5 render f =+    Syntax QLFull match render+  where+    match (TargetStringFileStatus5 str1 str2 str3 str4 str5)+            = f str1 str2 str3 str4 str5+    match _ = mzero++syntaxForm7 render f =+    Syntax QLFull match render+  where+    match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7)+            = f str1 str2 str3 str4 str5 str6 str7+    match _ = mzero++dispP :: Package p => p -> String+dispP = prettyShow . packageName++dispPN :: PackageName -> String+dispPN = prettyShow++dispC :: PackageId -> ComponentName -> String+dispC = componentStringName . packageName++dispC' :: PackageName -> ComponentName -> String+dispC' = componentStringName++dispCN :: UnqualComponentName -> String+dispCN = prettyShow++dispK :: ComponentKind -> String+dispK = showComponentKindShort++dispCK :: ComponentName -> String+dispCK = dispK . componentKind++dispF :: ComponentKind -> String+dispF = showComponentKindFilterShort++dispM :: ModuleName -> String+dispM = prettyShow+++-------------------------------+-- Package and component info+--++data KnownTargets = KnownTargets {+       knownPackagesAll       :: [KnownPackage],+       knownPackagesPrimary   :: [KnownPackage],+       knownPackagesOther     :: [KnownPackage],+       knownComponentsAll     :: [KnownComponent],+       knownComponentsPrimary :: [KnownComponent],+       knownComponentsOther   :: [KnownComponent]+     }+  deriving Show++data KnownPackage =+     KnownPackage {+       pinfoId          :: PackageId,+       pinfoDirectory   :: Maybe (FilePath, FilePath),+       pinfoPackageFile :: Maybe (FilePath, FilePath),+       pinfoComponents  :: [KnownComponent]+     }+   | KnownPackageName {+       pinfoName        :: PackageName+     }+  deriving Show++data KnownComponent = KnownComponent {+       cinfoName      :: ComponentName,+       cinfoStrName   :: ComponentStringName,+       cinfoPackageId :: PackageId,+       cinfoSrcDirs   :: [FilePath],+       cinfoModules   :: [ModuleName],+       cinfoHsFiles   :: [FilePath],   -- other hs files (like main.hs)+       cinfoCFiles    :: [FilePath],+       cinfoJsFiles   :: [FilePath]+     }+  deriving Show++type ComponentStringName = String++knownPackageName :: KnownPackage -> PackageName+knownPackageName KnownPackage{pinfoId}       = packageName pinfoId+knownPackageName KnownPackageName{pinfoName} = pinfoName++emptyKnownTargets :: KnownTargets+emptyKnownTargets = KnownTargets [] [] [] [] [] []++getKnownTargets :: (Applicative m, Monad m)+                => DirActions m+                -> [PackageSpecifier (SourcePackage (PackageLocation a))]+                -> m KnownTargets+getKnownTargets dirActions@DirActions{..} pkgs = do+    pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs+    cwd   <- getCurrentDirectory+    let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo+    return KnownTargets {+      knownPackagesAll       = pinfo,+      knownPackagesPrimary   = ppinfo,+      knownPackagesOther     = opinfo,+      knownComponentsAll     = allComponentsIn pinfo,+      knownComponentsPrimary = allComponentsIn ppinfo,+      knownComponentsOther   = allComponentsIn opinfo+    }+  where+    selectPrimaryPackage :: FilePath+                         -> [KnownPackage]+                         -> ([KnownPackage], [KnownPackage])+    selectPrimaryPackage cwd = partition isPkgDirCwd+      where+        isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) }+          | dir == cwd = True+        isPkgDirCwd _  = False+    allComponentsIn ps =+      [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ]+++collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m+                        -> PackageSpecifier (SourcePackage (PackageLocation a))+                        -> m KnownPackage+collectKnownPackageInfo _ (NamedPackage pkgname _props) =+    return (KnownPackageName pkgname)+collectKnownPackageInfo dirActions@DirActions{..}+                  (SpecificSourcePackage SourcePackage {+                    srcpkgDescription = pkg,+                    srcpkgSource      = loc+                  }) = do+    (pkgdir, pkgfile) <-+      case loc of+        --TODO: local tarballs, remote tarballs etc+        LocalUnpackedPackage dir -> do+          dirabs <- canonicalizePath dir+          dirrel <- makeRelativeToCwd dirActions dirabs+          --TODO: ought to get this earlier in project reading+          let fileabs = dirabs </> prettyShow (packageName pkg) <.> "cabal"+              filerel = dirrel </> prettyShow (packageName pkg) <.> "cabal"+          exists <- doesFileExist fileabs+          return ( Just (dirabs, dirrel)+                 , if exists then Just (fileabs, filerel) else Nothing+                 )+        _ -> return (Nothing, Nothing)+    let pinfo =+          KnownPackage {+            pinfoId          = packageId pkg,+            pinfoDirectory   = pkgdir,+            pinfoPackageFile = pkgfile,+            pinfoComponents  = collectKnownComponentInfo+                                 (flattenPackageDescription pkg)+          }+    return pinfo+++collectKnownComponentInfo :: PackageDescription -> [KnownComponent]+collectKnownComponentInfo pkg =+    [ KnownComponent {+        cinfoName      = componentName c,+        cinfoStrName   = componentStringName (packageName pkg) (componentName c),+        cinfoPackageId = packageId pkg,+        cinfoSrcDirs   = ordNub (map getSymbolicPath (hsSourceDirs bi)),+        cinfoModules   = ordNub (componentModules c),+        cinfoHsFiles   = ordNub (componentHsFiles c),+        cinfoCFiles    = ordNub (cSources bi),+        cinfoJsFiles   = ordNub (jsSources bi)+      }+    | c <- pkgComponents pkg+    , let bi = componentBuildInfo c ]+++componentStringName :: PackageName -> ComponentName -> ComponentStringName+componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname+componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name+componentStringName _ (CFLibName name)  = unUnqualComponentName name+componentStringName _ (CExeName   name) = unUnqualComponentName name+componentStringName _ (CTestName  name) = unUnqualComponentName name+componentStringName _ (CBenchName name) = unUnqualComponentName name++componentModules :: Component -> [ModuleName]+-- I think it's unlikely users will ask to build a requirement+-- which is not mentioned locally.+componentModules (CLib   lib)   = explicitLibModules lib+componentModules (CFLib  flib)  = foreignLibModules flib+componentModules (CExe   exe)   = exeModules exe+componentModules (CTest  test)  = testModules test+componentModules (CBench bench) = benchmarkModules bench++componentHsFiles :: Component -> [FilePath]+componentHsFiles (CExe exe) = [modulePath exe]+componentHsFiles (CTest  TestSuite {+                           testInterface = TestSuiteExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles (CBench Benchmark {+                           benchmarkInterface = BenchmarkExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles _          = []+++------------------------------+-- Matching meta targets+--++guardNamespaceMeta :: String -> Match ()+guardNamespaceMeta = guardToken [""] "meta namespace"++guardMetaAll :: String -> Match ()+guardMetaAll = guardToken ["all"] "meta-target 'all'"++guardNamespacePackage :: String -> Match ()+guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace"++guardNamespaceCwd :: String -> Match ()+guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace"++guardNamespaceModule :: String -> Match ()+guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace"++guardNamespaceFile :: String -> Match ()+guardNamespaceFile = guardToken ["file"] "'file' namespace"++guardToken :: [String] -> String -> String -> Match ()+guardToken tokens msg s+  | caseFold s `elem` tokens = increaseConfidence+  | otherwise                = matchErrorExpected msg s+++------------------------------+-- Matching component kinds+--++componentKind :: ComponentName -> ComponentKind+componentKind (CLibName _)   = LibKind+componentKind (CFLibName _)  = FLibKind+componentKind (CExeName   _) = ExeKind+componentKind (CTestName  _) = TestKind+componentKind (CBenchName _) = BenchKind++cinfoKind :: KnownComponent -> ComponentKind+cinfoKind = componentKind . cinfoName++matchComponentKind :: String -> Match ComponentKind+matchComponentKind s+  | s' `elem` liblabels   = increaseConfidence >> return LibKind+  | s' `elem` fliblabels  = increaseConfidence >> return FLibKind+  | s' `elem` exelabels   = increaseConfidence >> return ExeKind+  | s' `elem` testlabels  = increaseConfidence >> return TestKind+  | s' `elem` benchlabels = increaseConfidence >> return BenchKind+  | otherwise             = matchErrorExpected "component kind" s+  where+    s'         = caseFold s+    liblabels   = ["lib", "library"]+    fliblabels  = ["flib", "foreign-library"]+    exelabels   = ["exe", "executable"]+    testlabels  = ["tst", "test", "test-suite"]+    benchlabels = ["bench", "benchmark"]++matchComponentKindFilter :: String -> Match ComponentKind+matchComponentKindFilter s+  | s' `elem` liblabels   = increaseConfidence >> return LibKind+  | s' `elem` fliblabels  = increaseConfidence >> return FLibKind+  | s' `elem` exelabels   = increaseConfidence >> return ExeKind+  | s' `elem` testlabels  = increaseConfidence >> return TestKind+  | s' `elem` benchlabels = increaseConfidence >> return BenchKind+  | otherwise             = matchErrorExpected "component kind filter" s+  where+    s'          = caseFold s+    liblabels   = ["libs", "libraries"]+    fliblabels  = ["flibs", "foreign-libraries"]+    exelabels   = ["exes", "executables"]+    testlabels  = ["tests", "test-suites"]+    benchlabels = ["benches", "benchmarks"]++showComponentKind :: ComponentKind -> String+showComponentKind LibKind   = "library"+showComponentKind FLibKind  = "foreign library"+showComponentKind ExeKind   = "executable"+showComponentKind TestKind  = "test-suite"+showComponentKind BenchKind = "benchmark"++showComponentKindShort :: ComponentKind -> String+showComponentKindShort LibKind   = "lib"+showComponentKindShort FLibKind  = "flib"+showComponentKindShort ExeKind   = "exe"+showComponentKindShort TestKind  = "test"+showComponentKindShort BenchKind = "bench"++showComponentKindFilterShort :: ComponentKind -> String+showComponentKindFilterShort LibKind   = "libs"+showComponentKindFilterShort FLibKind  = "flibs"+showComponentKindFilterShort ExeKind   = "exes"+showComponentKindFilterShort TestKind  = "tests"+showComponentKindFilterShort BenchKind = "benchmarks"+++------------------------------+-- Matching package targets+--++guardPackage :: String -> FileStatus -> Match ()+guardPackage str fstatus =+      guardPackageName str+  <|> guardPackageDir  str fstatus+  <|> guardPackageFile str fstatus+++guardPackageName :: String -> Match ()+guardPackageName s+  | validPackageName s = increaseConfidence+  | otherwise          = matchErrorExpected "package name" s++validPackageName :: String -> Bool+validPackageName s =+       all validPackageNameChar s+    && not (null s)+  where+    validPackageNameChar c = isAlphaNum c || c == '-'+++guardPackageDir :: String -> FileStatus -> Match ()+guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence+guardPackageDir str _ = matchErrorExpected "package directory" str+++guardPackageFile :: String -> FileStatus -> Match ()+guardPackageFile _ (FileStatusExistsFile file)+                       | takeExtension file == ".cabal"+                       = increaseConfidence+guardPackageFile str _ = matchErrorExpected "package .cabal file" str+++matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage+matchPackage pinfo = \str fstatus ->+    orNoThingIn "project" "" $+          matchPackageName pinfo str+    <//> (matchPackageNameUnknown str+     <|>  matchPackageDir  pinfo str fstatus+     <|>  matchPackageFile pinfo str fstatus)+++matchPackageName :: [KnownPackage] -> String -> Match KnownPackage+matchPackageName ps = \str -> do+    guard (validPackageName str)+    orNoSuchThing "package" str+                  (map (prettyShow . knownPackageName) ps) $+      increaseConfidenceFor $+        matchInexactly caseFold (prettyShow . knownPackageName) ps str+++matchPackageNameUnknown :: String -> Match KnownPackage+matchPackageNameUnknown str = do+    pn <- matchParse str+    unknownMatch (KnownPackageName pn)+++matchPackageDir :: [KnownPackage]+                -> String -> FileStatus -> Match KnownPackage+matchPackageDir ps = \str fstatus ->+    case fstatus of+      FileStatusExistsDir canondir ->+        orNoSuchThing "package directory" str (map (snd . fst) dirs) $+          increaseConfidenceFor $+            fmap snd $ matchExactly (fst . fst) dirs canondir+      _ -> mzero+  where+    dirs = [ ((dabs,drel),p)+           | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ]+++matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage+matchPackageFile ps = \str fstatus -> do+    case fstatus of+      FileStatusExistsFile canonfile ->+        orNoSuchThing "package .cabal file" str (map (snd . fst) files) $+          increaseConfidenceFor $+            fmap snd $ matchExactly (fst . fst) files canonfile+      _ -> mzero+  where+    files = [ ((fabs,frel),p)+            | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ]++--TODO: test outcome when dir exists but doesn't match any known one++--TODO: perhaps need another distinction, vs no such thing, point is the+--      thing is not known, within the project, but could be outside project+++------------------------------+-- Matching component targets+--+++guardComponentName :: String -> Match ()+guardComponentName s+  | all validComponentChar s+    && not (null s)  = increaseConfidence+  | otherwise        = matchErrorExpected "component name" s+  where+    validComponentChar c = isAlphaNum c || c == '.'+                        || c == '_' || c == '-' || c == '\''+++matchComponentName :: [KnownComponent] -> String -> Match KnownComponent+matchComponentName cs str =+    orNoSuchThing "component" str (map cinfoStrName cs)+  $ increaseConfidenceFor+  $ matchInexactly caseFold cinfoStrName cs str+++matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String+                          -> Match KnownComponent+matchComponentKindAndName cs ckind str =+    orNoSuchThing (showComponentKind ckind ++ " component") str+                  (map render cs)+  $ increaseConfidenceFor+  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))+                   (\c -> (cinfoKind c, cinfoStrName c))+                   cs+                   (ckind, str)+  where+    render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c+++------------------------------+-- Matching module targets+--++guardModuleName :: String -> Match ()+guardModuleName s =+  case simpleParsec s :: Maybe ModuleName of+    Just _                   -> increaseConfidence+    _ | all validModuleChar s+        && not (null s)      -> return ()+      | otherwise            -> matchErrorExpected "module name" s+    where+      validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''+++matchModuleName :: [ModuleName] -> String -> Match ModuleName+matchModuleName ms str =+    orNoSuchThing "module" str (map prettyShow ms)+  $ increaseConfidenceFor+  $ matchInexactly caseFold prettyShow ms str+++matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)+matchModuleNameAnd ms str =+    orNoSuchThing "module" str (map (prettyShow . fst) ms)+  $ increaseConfidenceFor+  $ matchInexactly caseFold (prettyShow . fst) ms str+++matchModuleNameUnknown :: String -> Match ModuleName+matchModuleNameUnknown str =+    expecting "module" str+  $ increaseConfidenceFor+  $ matchParse str+++------------------------------+-- Matching file targets+--++matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus+                            -> Match (FilePath, KnownPackage)+matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =+    increaseConfidenceFor $+      matchDirectoryPrefix pkgdirs filepath+  where+    pkgdirs = [ (dir, p)+              | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ]+matchPackageDirectoryPrefix _ _ = mzero+++matchComponentFile :: [KnownComponent] -> String+                   -> Match (FilePath, KnownComponent)+matchComponentFile cs str =+    orNoSuchThing "file" str [] $+        matchComponentModuleFile cs str+    <|> matchComponentOtherFile  cs str+++matchComponentOtherFile :: [KnownComponent] -> String+                        -> Match (FilePath, KnownComponent)+matchComponentOtherFile cs =+    matchFile+      [ (normalise (srcdir </> file), c)+      | c      <- cs+      , srcdir <- cinfoSrcDirs c+      , file   <- cinfoHsFiles c+               ++ cinfoCFiles  c+               ++ cinfoJsFiles c+      ]+      . normalise+++matchComponentModuleFile :: [KnownComponent] -> String+                         -> Match (FilePath, KnownComponent)+matchComponentModuleFile cs str = do+    matchFile+      [ (normalise (d </> toFilePath m), c)+      | c <- cs+      , d <- cinfoSrcDirs c+      , m <- cinfoModules c+      ]+      (dropExtension (normalise str)) -- Drop the extension because FileTarget+                                      -- is stored without the extension++-- utils++matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)+matchFile fs =+      increaseConfidenceFor+    . matchInexactly caseFold fst fs++matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)+matchDirectoryPrefix dirs filepath =+    tryEach $+      [ (file, x)+      | (dir,x) <- dirs+      , file <- maybeToList (stripDirectory dir) ]+  where+    stripDirectory :: FilePath -> Maybe FilePath+    stripDirectory dir =+      joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit++    filepathsplit = splitDirectories filepath+++------------------------------+-- Matching monad+--++-- | A matcher embodies a way to match some input as being some recognised+-- value. In particular it deals with multiple and ambiguous matches.+--+-- There are various matcher primitives ('matchExactly', 'matchInexactly'),+-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we+-- can run a matcher against an input using 'findMatch'.+--+data Match a = NoMatch           !Confidence [MatchError]+             | Match !MatchClass !Confidence [a]+  deriving Show++-- | The kind of match, inexact or exact. We keep track of this so we can+-- prefer exact over inexact matches. The 'Ord' here is important: we try+-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom.+--+data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package+                          --   name without it being a specific known package+                | Inexact -- ^ Matches a known thing inexactly+                          --   e.g. matches a known package case insensitively+                | Exact   -- ^ Exactly matches a known thing,+                          --   e.g. matches a known package case sensitively+  deriving (Show, Eq, Ord)++type Confidence = Int++data MatchError = MatchErrorExpected String String            -- thing got+                | MatchErrorNoSuch   String String [String]   -- thing got alts+                | MatchErrorIn       String String MatchError -- kind  thing+  deriving (Show, Eq)+++instance Functor Match where+    fmap _ (NoMatch d ms) = NoMatch d ms+    fmap f (Match m d xs) = Match m d (fmap f xs)++instance Applicative Match where+    pure a = Match Exact 0 [a]+    (<*>)  = ap++instance Alternative Match where+    empty = NoMatch 0 []+    (<|>) = matchPlus++instance Monad Match where+    return             = pure+    NoMatch d ms >>= _ = NoMatch d ms+    Match m d xs >>= f =+      -- To understand this, it needs to be read in context with the+      -- implementation of 'matchPlus' below+      case msum (map f xs) of+        Match m' d' xs' -> Match (min m m') (d + d') xs'+        -- The minimum match class is the one we keep. The match depth is+        -- tracked but not used in the Match case.++        NoMatch  d' ms  -> NoMatch          (d + d') ms+        -- Here is where we transfer the depth we were keeping track of in+        -- the Match case over to the NoMatch case where it finally gets used.++instance MonadPlus Match where+    mzero = empty+    mplus = matchPlus++(<//>) :: Match a -> Match a -> Match a+(<//>) = matchPlusShadowing++infixl 3 <//>++-- | Combine two matchers. Exact matches are used over inexact matches+-- but if we have multiple exact, or inexact then the we collect all the+-- ambiguous matches.+--+-- This operator is associative, has unit 'mzero' and is also commutative.+--+matchPlus :: Match a -> Match a -> Match a+matchPlus a@(Match _ _ _ )   (NoMatch _ _) = a+matchPlus   (NoMatch _ _ ) b@(Match _ _ _) = b+matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b)+  | d_a > d_b = a  -- We only really make use of the depth in the NoMatch case.+  | d_a < d_b = b+  | otherwise = NoMatch d_a (ms_a ++ ms_b)+matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b)+  | m_a > m_b = a  -- exact over inexact+  | m_a < m_b = b  -- exact over inexact+  | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b)++-- | Combine two matchers. This is similar to 'matchPlus' with the+-- difference that an exact match from the left matcher shadows any exact+-- match on the right. Inexact matches are still collected however.+--+-- This operator is associative, has unit 'mzero' and is not commutative.+--+matchPlusShadowing :: Match a -> Match a -> Match a+matchPlusShadowing a@(Match Exact _ _) _ = a+matchPlusShadowing a                   b = matchPlus a b+++------------------------------+-- Various match primitives+--++matchErrorExpected :: String -> String -> Match a+matchErrorExpected thing got      = NoMatch 0 [MatchErrorExpected thing got]++matchErrorNoSuch :: String -> String -> [String] -> Match a+matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts]++expecting :: String -> String -> Match a -> Match a+expecting thing got (NoMatch 0 _) = matchErrorExpected thing got+expecting _     _   m             = m++orNoSuchThing :: String -> String -> [String] -> Match a -> Match a+orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts+orNoSuchThing _     _   _    m             = m++orNoThingIn :: String -> String -> Match a -> Match a+orNoThingIn kind name (NoMatch n ms) =+    NoMatch n [ MatchErrorIn kind name m | m <- ms ]+orNoThingIn _ _ m = m++increaseConfidence :: Match ()+increaseConfidence = Match Exact 1 [()]++increaseConfidenceFor :: Match a -> Match a+increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r++nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a+nubMatchesBy _  (NoMatch d msgs) = NoMatch d msgs+nubMatchesBy eq (Match m d xs)   = Match m d (nubBy eq xs)++-- | Lift a list of matches to an exact match.+--+exactMatches, inexactMatches :: [a] -> Match a++exactMatches [] = mzero+exactMatches xs = Match Exact 0 xs++inexactMatches [] = mzero+inexactMatches xs = Match Inexact 0 xs++unknownMatch :: a -> Match a+unknownMatch x = Match Unknown 0 [x]++tryEach :: [a] -> Match a+tryEach = exactMatches+++------------------------------+-- Top level match runner+--++-- | Given a matcher and a key to look up, use the matcher to find all the+-- possible matches. There may be 'None', a single 'Unambiguous' match or+-- you may have an 'Ambiguous' match with several possibilities.+--+findMatch :: Match a -> MaybeAmbiguous a+findMatch match = case match of+  NoMatch _ msgs -> None msgs+  Match _ _  [x] -> Unambiguous x+  Match m d   [] -> error $ "findMatch: impossible: " ++ show match'+                      where match' = Match m d [] :: Match ()+                    -- TODO: Maybe use Data.List.NonEmpty inside+                    -- Match so that this case would be correct+                    -- by construction?+  Match m _   xs -> Ambiguous m xs++data MaybeAmbiguous a = None [MatchError]+                      | Unambiguous a+                      | Ambiguous MatchClass [a]+  deriving Show+++------------------------------+-- Basic matchers+--++-- | A primitive matcher that looks up a value in a finite 'Map'. The+-- value must match exactly.+--+matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a)+matchExactly key xs =+    \k -> case Map.lookup k m of+            Nothing -> mzero+            Just ys -> exactMatches ys+  where+    m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]++-- | A primitive matcher that looks up a value in a finite 'Map'. It checks+-- for an exact or inexact match. We get an inexact match if the match+-- is not exact, but the canonical forms match. It takes a canonicalisation+-- function for this purpose.+--+-- So for example if we used string case fold as the canonicalisation+-- function, then we would get case insensitive matching (but it will still+-- report an exact match when the case matches too).+--+matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k)+               -> [a] -> (k -> Match a)+matchInexactly cannonicalise key xs =+    \k -> case Map.lookup k m of+            Just ys -> exactMatches ys+            Nothing -> case Map.lookup (cannonicalise k) m' of+                         Just ys -> inexactMatches ys+                         Nothing -> mzero+  where+    m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]++    -- the map of canonicalised keys to groups of inexact matches+    m' = Map.mapKeysWith (++) cannonicalise m++matchParse :: Parsec a => String -> Match a+matchParse = maybe mzero return . simpleParsec+++------------------------------+-- Utils+--++caseFold :: String -> String+caseFold = lowercase++-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the+-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's+-- primary library from named private libraries.+--+mkComponentName :: PackageName+                -> ComponentKind+                -> UnqualComponentName+                -> ComponentName+mkComponentName pkgname ckind ucname =+  case ckind of+    LibKind+      | packageNameToUnqualComponentName pkgname == ucname+                  -> CLibName LMainLibName+      | otherwise -> CLibName $ LSubLibName ucname+    FLibKind      -> CFLibName   ucname+    ExeKind       -> CExeName    ucname+    TestKind      -> CTestName   ucname+    BenchKind     -> CBenchName  ucname+++------------------------------+-- Example inputs+--++{-+ex1pinfo :: [KnownPackage]+ex1pinfo =+  [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $+    KnownPackage {+      pinfoId          = PackageIdentifier (mkPackageName "foo") (mkVersion [1]),+      pinfoDirectory   = Just ("/the/foo", "foo"),+      pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"),+      pinfoComponents  = []+    }+  , KnownPackage {+      pinfoId          = PackageIdentifier (mkPackageName "bar") (mkVersion [1]),+      pinfoDirectory   = Just ("/the/bar", "bar"),+      pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"),+      pinfoComponents  = []+    }+  ]+  where+    addComponent n ds ms p =+      p {+        pinfoComponents =+            KnownComponent n (componentStringName (pinfoId p) n)+                          p ds (map mkMn ms)+                          [] [] []+          : pinfoComponents p+      }++    mkMn :: String -> ModuleName+    mkMn  = ModuleName.fromString+-}+{-+stargets =+  [ TargetComponent (CExeName "foo")  WholeComponent+  , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo"))+  , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo"))+  ]+    where+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse++ex_pkgid :: PackageIdentifier+Just ex_pkgid = simpleParse "thelib"+-}++{-+ex_cs :: [KnownComponent]+ex_cs =+  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])+  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])+  ]+    where+    mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms)+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse+    pkgid :: PackageIdentifier+    Just pkgid = simpleParse "thelib"+-}
+ src/Distribution/Client/Targets.hs view
@@ -0,0 +1,746 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Targets+-- Copyright   :  (c) Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified targets+-----------------------------------------------------------------------------+module Distribution.Client.Targets (+  -- * User targets+  UserTarget(..),+  readUserTargets,++  -- * Resolving user targets to package specifiers+  resolveUserTargets,++  -- ** Detailed interface+  UserTargetProblem(..),+  readUserTarget,+  reportUserTargetProblems,+  expandUserTarget,++  PackageTarget(..),+  fetchPackageTarget,+  readPackageTarget,++  PackageTargetProblem(..),+  reportPackageTargetProblems,++  disambiguatePackageTargets,+  disambiguatePackageName,++  -- * User constraints+  UserQualifier(..),+  UserConstraintScope(..),+  UserConstraint(..),+  userConstraintPackageName,+  readUserConstraint,+  userToPackageConstraint,++  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Package+         ( Package(..), PackageName, unPackageName, mkPackageName+         , packageName )+import Distribution.Types.Dependency+import Distribution.Client.Types+         ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage+         , PackageSpecifier(..) )++import           Distribution.Solver.Types.OptionalStanza+import           Distribution.Solver.Types.PackageConstraint+import           Distribution.Solver.Types.PackagePath+import           Distribution.Solver.Types.PackageIndex (PackageIndex)+import qualified Distribution.Solver.Types.PackageIndex as PackageIndex+import           Distribution.Solver.Types.SourcePackage++import qualified Distribution.Client.World as World+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Distribution.Client.Tar as Tar+import Distribution.Client.FetchUtils+import Distribution.Client.Utils ( tryFindPackageDesc )+import Distribution.Client.GlobalFlags+         ( RepoContext(..) )+import Distribution.Types.PackageVersionConstraint+         ( PackageVersionConstraint (..) )++import Distribution.PackageDescription+         ( GenericPackageDescription )+import Distribution.Types.Flag+         ( nullFlagAssignment, parsecFlagAssignmentNonEmpty )+import Distribution.Version+         ( anyVersion, isAnyVersion )+import Distribution.Simple.Utils+         ( die', warn, lowercase )++import Distribution.PackageDescription.Parsec+         ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe )++import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Distribution.Client.GZipUtils as GZipUtils+import qualified Distribution.Compat.CharParsing as P+import System.FilePath+         ( takeExtension, dropExtension, takeDirectory, splitPath )+import System.Directory+         ( doesFileExist, doesDirectoryExist )+import Network.URI+         ( URI(..), URIAuth(..), parseAbsoluteURI )++-- ------------------------------------------------------------+-- * User targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a package or package collection.+--+data UserTarget =++     -- | A partially specified package, identified by name and possibly with+     -- an exact version or a version constraint.+     --+     -- > cabal install foo+     -- > cabal install foo-1.0+     -- > cabal install 'foo < 2'+     --+     UserTargetNamed PackageVersionConstraint++     -- | A special virtual package that refers to the collection of packages+     -- recorded in the world file that the user specifically installed.+     --+     -- > cabal install world+     --+   | UserTargetWorld++     -- | A specific package that is unpacked in a local directory, often the+     -- current directory.+     --+     -- > cabal install .+     -- > cabal install ../lib/other+     --+     -- * Note: in future, if multiple @.cabal@ files are allowed in a single+     -- directory then this will refer to the collection of packages.+     --+   | UserTargetLocalDir FilePath++     -- | A specific local unpacked package, identified by its @.cabal@ file.+     --+     -- > cabal install foo.cabal+     -- > cabal install ../lib/other/bar.cabal+     --+   | UserTargetLocalCabalFile FilePath++     -- | A specific package that is available as a local tarball file+     --+     -- > cabal install dist/foo-1.0.tar.gz+     -- > cabal install ../build/baz-1.0.tar.gz+     --+   | UserTargetLocalTarball FilePath++     -- | A specific package that is available as a remote tarball file+     --+     -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz+     --+   | UserTargetRemoteTarball URI+  deriving (Show,Eq)+++-- ------------------------------------------------------------+-- * Parsing and checking user targets+-- ------------------------------------------------------------++readUserTargets :: Verbosity -> [String] -> IO [UserTarget]+readUserTargets verbosity targetStrs = do+    (problems, targets) <- liftM partitionEithers+                                 (traverse readUserTarget targetStrs)+    reportUserTargetProblems verbosity problems+    return targets+++data UserTargetProblem+   = UserTargetUnexpectedFile      String+   | UserTargetNonexistantFile     String+   | UserTargetUnexpectedUriScheme String+   | UserTargetUnrecognisedUri     String+   | UserTargetUnrecognised        String+   | UserTargetBadWorldPkg+  deriving Show++readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)+readUserTarget targetstr =+    case eitherParsec targetstr of+      Right (PackageVersionConstraint pkgn verrange)+        | pkgn == mkPackageName "world"+          -> return $ if verrange == anyVersion+                      then Right UserTargetWorld+                      else Left  UserTargetBadWorldPkg+      Right dep -> return (Right (UserTargetNamed dep))+      Left _err -> do+        fileTarget <- testFileTargets targetstr+        case fileTarget of+          Just target -> return target+          Nothing     ->+            case testUriTargets targetstr of+              Just target -> return target+              Nothing     -> return (Left (UserTargetUnrecognised targetstr))+  where+    testFileTargets filename = do+      isDir  <- doesDirectoryExist filename+      isFile <- doesFileExist filename+      parentDirExists <- case takeDirectory filename of+                           []  -> return False+                           dir -> doesDirectoryExist dir+      let result+            | isDir+            = Just (Right (UserTargetLocalDir filename))++            | isFile && extensionIsTarGz filename+            = Just (Right (UserTargetLocalTarball filename))++            | isFile && takeExtension filename == ".cabal"+            = Just (Right (UserTargetLocalCabalFile filename))++            | isFile+            = Just (Left (UserTargetUnexpectedFile filename))++            | parentDirExists+            = Just (Left (UserTargetNonexistantFile filename))++            | otherwise+            = Nothing+      return result++    testUriTargets str =+      case parseAbsoluteURI str of+        Just uri@URI {+            uriScheme    = scheme,+            uriAuthority = Just URIAuth { uriRegName = host }+          }+          | scheme /= "http:" && scheme /= "https:" ->+            Just (Left (UserTargetUnexpectedUriScheme targetstr))++          | null host ->+            Just (Left (UserTargetUnrecognisedUri targetstr))++          | otherwise ->+            Just (Right (UserTargetRemoteTarball uri))+        _ -> Nothing++    extensionIsTarGz f = takeExtension f                 == ".gz"+                      && takeExtension (dropExtension f) == ".tar"++reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()+reportUserTargetProblems verbosity problems = do+    case [ target | UserTargetUnrecognised target <- problems ] of+      []     -> return ()+      target -> die' verbosity+              $ unlines+                  [ "Unrecognised target '" ++ name ++ "'."+                  | name <- target ]+             ++ "Targets can be:\n"+             ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"+             ++ " - the special 'world' target\n"+             ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"+             ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"++    case [ () | UserTargetBadWorldPkg <- problems ] of+      [] -> return ()+      _  -> die' verbosity "The special 'world' target does not take any version."++    case [ target | UserTargetNonexistantFile target <- problems ] of+      []     -> return ()+      target -> die' verbosity+              $ unlines+                  [ "The file does not exist '" ++ name ++ "'."+                  | name <- target ]++    case [ target | UserTargetUnexpectedFile target <- problems ] of+      []     -> return ()+      target -> die' verbosity+              $ unlines+                  [ "Unrecognised file target '" ++ name ++ "'."+                  | name <- target ]+             ++ "File targets can be either package tarballs 'pkgname.tar.gz' "+             ++ "or cabal files 'pkgname.cabal'."++    case [ target | UserTargetUnexpectedUriScheme target <- problems ] of+      []     -> return ()+      target -> die' verbosity+              $ unlines+                  [ "URL target not supported '" ++ name ++ "'."+                  | name <- target ]+             ++ "Only 'http://' and 'https://' URLs are supported."++    case [ target | UserTargetUnrecognisedUri target <- problems ] of+      []     -> return ()+      target -> die' verbosity+              $ unlines+                  [ "Unrecognise URL target '" ++ name ++ "'."+                  | name <- target ]+++-- ------------------------------------------------------------+-- * Resolving user targets to package specifiers+-- ------------------------------------------------------------++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to. They can either be specific packages (local dirs, tarballs etc)+-- or they can be named packages (with or without version info).+--+resolveUserTargets :: Package pkg+                   => Verbosity+                   -> RepoContext+                   -> FilePath+                   -> PackageIndex pkg+                   -> [UserTarget]+                   -> IO [PackageSpecifier UnresolvedSourcePackage]+resolveUserTargets verbosity repoCtxt worldFile available userTargets = do++    -- given the user targets, get a list of fully or partially resolved+    -- package references+    packageTargets <- traverse (readPackageTarget verbosity)+                  =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat+                  =<< traverse (expandUserTarget verbosity worldFile) userTargets++    -- users are allowed to give package names case-insensitively, so we must+    -- disambiguate named package references+    let (problems, packageSpecifiers) =+           disambiguatePackageTargets available availableExtra packageTargets++        -- use any extra specific available packages to help us disambiguate+        availableExtra = [ packageName pkg+                         | PackageTargetLocation pkg <- packageTargets ]++    reportPackageTargetProblems verbosity problems++    return packageSpecifiers+++-- ------------------------------------------------------------+-- * Package targets+-- ------------------------------------------------------------++-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.+-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.+--+data PackageTarget pkg =+     PackageTargetNamed      PackageName [PackageProperty] UserTarget++     -- | A package identified by name, but case insensitively, so it needs+     -- to be resolved to the right case-sensitive name.+   | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget+   | PackageTargetLocation pkg+  deriving (Show, Functor, Foldable, Traversable)+++-- ------------------------------------------------------------+-- * Converting user targets to package targets+-- ------------------------------------------------------------++-- | Given a user-specified target, expand it to a bunch of package targets+-- (each of which refers to only one package).+--+expandUserTarget :: Verbosity+                 -> FilePath+                 -> UserTarget+                 -> IO [PackageTarget (PackageLocation ())]+expandUserTarget verbosity worldFile userTarget = case userTarget of++    UserTargetNamed (PackageVersionConstraint name vrange) ->+      let props = [ PackagePropertyVersion vrange+                  | not (isAnyVersion vrange) ]+      in  return [PackageTargetNamedFuzzy name props userTarget]++    UserTargetWorld -> do+      worldPkgs <- World.getContents verbosity worldFile+      --TODO: should we warn if there are no world targets?+      return [ PackageTargetNamed name props userTarget+             | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs+             , let props = [ PackagePropertyVersion vrange+                           | not (isAnyVersion vrange) ]+                        ++ [ PackagePropertyFlags flags+                           | not (nullFlagAssignment flags) ] ]++    UserTargetLocalDir dir ->+      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++    UserTargetLocalCabalFile file -> do+      let dir = takeDirectory file+      _   <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check+      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++    UserTargetLocalTarball tarballFile ->+      return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]++    UserTargetRemoteTarball tarballURL ->+      return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]++localPackageError :: FilePath -> String+localPackageError dir =+    "Error reading local package.\nCouldn't find .cabal file in: " ++ dir++-- ------------------------------------------------------------+-- * Fetching and reading package targets+-- ------------------------------------------------------------+++-- | Fetch any remote targets so that they can be read.+--+fetchPackageTarget :: Verbosity+                   -> RepoContext+                   -> PackageTarget (PackageLocation ())+                   -> IO (PackageTarget ResolvedPkgLoc)+fetchPackageTarget verbosity repoCtxt = traverse $+  fetchPackage verbosity repoCtxt . fmap (const Nothing)+++-- | Given a package target that has been fetched, read the .cabal file.+--+-- This only affects targets given by location, named targets are unaffected.+--+readPackageTarget :: Verbosity+                  -> PackageTarget ResolvedPkgLoc+                  -> IO (PackageTarget UnresolvedSourcePackage)+readPackageTarget verbosity = traverse modifyLocation+  where+    modifyLocation location = case location of++      LocalUnpackedPackage dir -> do+        pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>=+                 readGenericPackageDescription verbosity+        return SourcePackage+          { srcpkgPackageId     = packageId pkg+          , srcpkgDescription   = pkg+          , srcpkgSource        = fmap Just location+          , srcpkgDescrOverride = Nothing+          }++      LocalTarballPackage tarballFile ->+        readTarballPackageTarget location tarballFile tarballFile++      RemoteTarballPackage tarballURL tarballFile ->+        readTarballPackageTarget location tarballFile (show tarballURL)++      RepoTarballPackage _repo _pkgid _ ->+        error "TODO: readPackageTarget RepoTarballPackage"+        -- For repo tarballs this info should be obtained from the index.++      RemoteSourceRepoPackage _srcRepo _ ->+        error "TODO: readPackageTarget RemoteSourceRepoPackage"+        -- This can't happen, because it would have errored out already+        -- in fetchPackage, via fetchPackageTarget before it gets to this+        -- function.+        --+        -- When that is corrected, this will also need to be fixed.++    readTarballPackageTarget location tarballFile tarballOriginalLoc = do+      (filename, content) <- extractTarballPackageCabalFile+                               tarballFile tarballOriginalLoc+      case parsePackageDescription' content of+        Nothing  -> die' verbosity $ "Could not parse the cabal file "+                       ++ filename ++ " in " ++ tarballFile+        Just pkg ->+          return SourcePackage+            { srcpkgPackageId     = packageId pkg+            , srcpkgDescription   = pkg+            , srcpkgSource        = fmap Just location+            , srcpkgDescrOverride = Nothing+            }++    extractTarballPackageCabalFile :: FilePath -> String+                                   -> IO (FilePath, BS.ByteString)+    extractTarballPackageCabalFile tarballFile tarballOriginalLoc =+          either (die' verbosity . formatErr) return+        . check+        . accumEntryMap+        . Tar.filterEntries isCabalFile+        . Tar.read+        . GZipUtils.maybeDecompress+      =<< BS.readFile tarballFile+      where+        formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg++        accumEntryMap = Tar.foldlEntries+                          (\m e -> Map.insert (Tar.entryTarPath e) e m)+                          Map.empty++        check (Left e)  = Left (show e)+        check (Right m) = case Map.elems m of+            []     -> Left noCabalFile+            [file] -> case Tar.entryContent file of+              Tar.NormalFile content _ -> Right (Tar.entryPath file, content)+              _                        -> Left noCabalFile+            _files -> Left multipleCabalFiles+          where+            noCabalFile        = "No cabal file found"+            multipleCabalFiles = "Multiple cabal files found"++        isCabalFile e = case splitPath (Tar.entryPath e) of+          [     _dir, file] -> takeExtension file == ".cabal"+          [".", _dir, file] -> takeExtension file == ".cabal"+          _                 -> False++    parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription+    parsePackageDescription' bs =+        parseGenericPackageDescriptionMaybe (BS.toStrict bs)++-- ------------------------------------------------------------+-- * Checking package targets+-- ------------------------------------------------------------++data PackageTargetProblem+   = PackageNameUnknown   PackageName               UserTarget+   | PackageNameAmbiguous PackageName [PackageName] UserTarget+  deriving Show+++-- | Users are allowed to give package names case-insensitively, so we must+-- disambiguate named package references.+--+disambiguatePackageTargets :: Package pkg'+                           => PackageIndex pkg'+                           -> [PackageName]+                           -> [PackageTarget pkg]+                           -> ( [PackageTargetProblem]+                              , [PackageSpecifier pkg] )+disambiguatePackageTargets availablePkgIndex availableExtra targets =+    partitionEithers (map disambiguatePackageTarget targets)+  where+    disambiguatePackageTarget packageTarget = case packageTarget of+      PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)++      PackageTargetNamed pkgname props userTarget+        | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)+                    -> Left (PackageNameUnknown pkgname userTarget)+        | otherwise -> Right (NamedPackage pkgname props)++      PackageTargetNamedFuzzy pkgname props userTarget ->+        case disambiguatePackageName packageNameEnv pkgname of+          None                 -> Left  (PackageNameUnknown+                                          pkgname userTarget)+          Ambiguous   pkgnames -> Left  (PackageNameAmbiguous+                                          pkgname pkgnames userTarget)+          Unambiguous pkgname' -> Right (NamedPackage pkgname' props)++    -- use any extra specific available packages to help us disambiguate+    packageNameEnv :: PackageNameEnv+    packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)+                             (extraPackageNameEnv availableExtra)+++-- | Report problems to the user. That is, if there are any problems+-- then raise an exception.+reportPackageTargetProblems :: Verbosity+                            -> [PackageTargetProblem] -> IO ()+reportPackageTargetProblems verbosity problems = do+    case [ pkg | PackageNameUnknown pkg originalTarget <- problems+               , not (isUserTagetWorld originalTarget) ] of+      []    -> return ()+      pkgs  -> die' verbosity $ unlines+                       [ "There is no package named '" ++ prettyShow name ++ "'. "+                       | name <- pkgs ]+                  ++ "You may need to run 'cabal update' to get the latest "+                  ++ "list of available packages."++    case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of+      []          -> return ()+      ambiguities -> die' verbosity $ unlines+                         [    "There is no package named '" ++ prettyShow name ++ "'. "+                           ++ (if length matches > 1+                               then "However, the following package names exist: "+                               else "However, the following package name exists: ")+                           ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches]+                           ++ "."+                         | (name, matches) <- ambiguities ]++    case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of+      []   -> return ()+      pkgs -> warn verbosity $+                 "The following 'world' packages will be ignored because "+              ++ "they refer to packages that cannot be found: "+              ++ intercalate ", " (map prettyShow pkgs) ++ "\n"+              ++ "You can suppress this warning by correcting the world file."+  where+    isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False+++-- ------------------------------------------------------------+-- * Disambiguating package names+-- ------------------------------------------------------------++data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]++-- | Given a package name and a list of matching names, figure out+-- which one it might be referring to. If there is an exact+-- case-sensitive match then that's ok (i.e. returned via+-- 'Unambiguous'). If it matches just one package case-insensitively+-- or if it matches multiple packages case-insensitively, in that case+-- the result is 'Ambiguous'.+--+-- Note: Before cabal 2.2, when only a single package matched+--       case-insensitively it would be considered 'Unambigious'.+--+disambiguatePackageName :: PackageNameEnv+                        -> PackageName+                        -> MaybeAmbiguous PackageName+disambiguatePackageName (PackageNameEnv pkgNameLookup) name =+    case nub (pkgNameLookup name) of+      []      -> None+      names   -> case find (name==) names of+                   Just name' -> Unambiguous name'+                   Nothing    -> Ambiguous names+++newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])++instance Monoid PackageNameEnv where+  mempty = PackageNameEnv (const [])+  mappend = (<>)++instance Semigroup PackageNameEnv where+  PackageNameEnv lookupA <> PackageNameEnv lookupB =+    PackageNameEnv (\name -> lookupA name ++ lookupB name)++indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv+indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup+  where+    pkgNameLookup pname =+      map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname)++extraPackageNameEnv :: [PackageName] -> PackageNameEnv+extraPackageNameEnv names = PackageNameEnv pkgNameLookup+  where+    pkgNameLookup pname =+      [ pname'+      | let lname = lowercase (unPackageName pname)+      , pname' <- names+      , lowercase (unPackageName pname') == lname ]+++-- ------------------------------------------------------------+-- * Package constraints+-- ------------------------------------------------------------++-- | Version of 'Qualifier' that a user may specify on the+-- command line.+data UserQualifier =+  -- | Top-level dependency.+  UserQualToplevel++  -- | Setup dependency.+  | UserQualSetup PackageName++  -- | Executable dependency.+  | UserQualExe PackageName PackageName+  deriving (Eq, Show, Generic)++instance Binary UserQualifier+instance Structured UserQualifier++-- | Version of 'ConstraintScope' that a user may specify on the+-- command line.+data UserConstraintScope =+  -- | Scope that applies to the package when it has the specified qualifier.+  UserQualified UserQualifier PackageName++  -- | Scope that applies to the package when it has a setup qualifier.+  | UserAnySetupQualifier PackageName++  -- | Scope that applies to the package when it has any qualifier.+  | UserAnyQualifier PackageName+  deriving (Eq, Show, Generic)++instance Binary UserConstraintScope+instance Structured UserConstraintScope++fromUserQualifier :: UserQualifier -> Qualifier+fromUserQualifier UserQualToplevel = QualToplevel+fromUserQualifier (UserQualSetup name) = QualSetup name+fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2++fromUserConstraintScope :: UserConstraintScope -> ConstraintScope+fromUserConstraintScope (UserQualified q pn) =+    ScopeQualified (fromUserQualifier q) pn+fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn+fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn++-- | Version of 'PackageConstraint' that the user can specify on+-- the command line.+data UserConstraint =+    UserConstraint UserConstraintScope PackageProperty+  deriving (Eq, Show, Generic)++instance Binary UserConstraint+instance Structured UserConstraint++userConstraintPackageName :: UserConstraint -> PackageName+userConstraintPackageName (UserConstraint scope _) = scopePN scope+  where+    scopePN (UserQualified _ pn) = pn+    scopePN (UserAnyQualifier pn) = pn+    scopePN (UserAnySetupQualifier pn) = pn++userToPackageConstraint :: UserConstraint -> PackageConstraint+userToPackageConstraint (UserConstraint scope prop) =+  PackageConstraint (fromUserConstraintScope scope) prop++readUserConstraint :: String -> Either String UserConstraint+readUserConstraint str =+    case explicitEitherParsec parsec str of+      Left err -> Left $ msgCannotParse ++ err+      Right c  -> Right c+  where+    msgCannotParse =+         "expected a (possibly qualified) package name followed by a " +++         "constraint, which is either a version range, 'installed', " +++         "'source', 'test', 'bench', or flags. "++instance Pretty UserConstraint where+  pretty (UserConstraint scope prop) =+    dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop++instance Parsec UserConstraint where+    parsec = do+        scope <- parseConstraintScope+        P.spaces+        prop <- P.choice+            [ PackagePropertyFlags                  <$> parsecFlagAssignmentNonEmpty -- headed by "+-"+            , PackagePropertyVersion                <$> parsec                       -- headed by "<=>" (will be)+            , PackagePropertyInstalled              <$ P.string "installed"+            , PackagePropertySource                 <$ P.string "source"+            , PackagePropertyStanzas [TestStanzas]  <$ P.string "test"+            , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"+            ]+        return (UserConstraint scope prop)++      where+        parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope+        parseConstraintScope = do+            pn <- parsec+            P.choice+                [ P.char '.' *> withDot pn+                , P.char ':' *> withColon pn+                , return (UserQualified UserQualToplevel pn)+                ]+          where+            withDot :: PackageName -> m UserConstraintScope+            withDot pn+                | pn == mkPackageName "any"   = UserAnyQualifier <$> parsec+                | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec+                | otherwise                   = P.unexpected $ "constraint scope: " ++ unPackageName pn++            withColon :: PackageName -> m UserConstraintScope+            withColon pn = UserQualified (UserQualSetup pn)+                <$  P.string "setup."+                <*> parsec
+ src/Distribution/Client/Types.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Types+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Various common data types for the entire cabal-install system+-----------------------------------------------------------------------------+module Distribution.Client.Types (+    module Distribution.Client.Types.AllowNewer,+    module Distribution.Client.Types.ConfiguredId,+    module Distribution.Client.Types.ConfiguredPackage,+    module Distribution.Client.Types.BuildResults,+    module Distribution.Client.Types.PackageLocation,+    module Distribution.Client.Types.PackageSpecifier,+    module Distribution.Client.Types.ReadyPackage,+    module Distribution.Client.Types.Repo,+    module Distribution.Client.Types.RepoName,+    module Distribution.Client.Types.SourcePackageDb,+    module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy,+) where+++import Distribution.Client.Types.AllowNewer+import Distribution.Client.Types.BuildResults+import Distribution.Client.Types.ConfiguredId+import Distribution.Client.Types.ConfiguredPackage+import Distribution.Client.Types.PackageLocation+import Distribution.Client.Types.PackageSpecifier+import Distribution.Client.Types.Repo+import Distribution.Client.Types.RepoName+import Distribution.Client.Types.ReadyPackage+import Distribution.Client.Types.SourcePackageDb+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
+ src/Distribution/Client/Types/AllowNewer.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.AllowNewer (+    AllowNewer (..),+    AllowOlder (..),+    RelaxDeps (..),+    mkRelaxDepSome,+    RelaxDepMod (..),+    RelaxDepScope (..),+    RelaxDepSubject (..),+    RelaxedDep (..),+    isRelaxDeps,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Parsec            (parsecLeadingCommaNonEmpty)+import Distribution.Types.PackageId   (PackageId, PackageIdentifier (..))+import Distribution.Types.PackageName (PackageName, mkPackageName)+import Distribution.Types.Version     (nullVersion)++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,+-- it may make sense to move these definitions to the Solver.Types+-- module++-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)+newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)+newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }+                   deriving (Eq, Read, Show, Generic)++-- | Generic data type for policy when relaxing bounds in dependencies.+-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending+-- on whether or not you are relaxing an lower or upper bound+-- (respectively).+data RelaxDeps =++  -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.+  --+  -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all+  -- dependencies, never choose versions newer (resp. older) than allowed.+    RelaxDepsSome [RelaxedDep]++  -- | Ignore upper (resp. lower) bounds in dependencies on all packages.+  --+  -- __Note__: This is should be semantically equivalent to+  --+  -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]+  --+  -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')+  | RelaxDepsAll+  deriving (Eq, Read, Show, Generic)++-- | Dependencies can be relaxed either for all packages in the install plan, or+-- only for some packages.+data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject+                deriving (Eq, Read, Show, Generic)++-- | Specify the scope of a relaxation, i.e. limit which depending+-- packages are allowed to have their version constraints relaxed.+data RelaxDepScope = RelaxDepScopeAll+                     -- ^ Apply relaxation in any package+                   | RelaxDepScopePackage !PackageName+                     -- ^ Apply relaxation to in all versions of a package+                   | RelaxDepScopePackageId !PackageId+                     -- ^ Apply relaxation to a specific version of a package only+                   deriving (Eq, Read, Show, Generic)++-- | Modifier for dependency relaxation+data RelaxDepMod = RelaxDepModNone  -- ^ Default semantics+                 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints+                 deriving (Eq, Read, Show, Generic)++-- | Express whether to relax bounds /on/ @all@ packages, or a single package+data RelaxDepSubject = RelaxDepSubjectAll+                     | RelaxDepSubjectPkg !PackageName+                     deriving (Eq, Ord, Read, Show, Generic)++instance Pretty RelaxedDep where+  pretty (RelaxedDep scope rdmod subj) = case scope of+      RelaxDepScopeAll          -> Disp.text "*:"               Disp.<> modDep+      RelaxDepScopePackage   p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep+      RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep+    where+      modDep = case rdmod of+               RelaxDepModNone  -> pretty subj+               RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj++instance Parsec RelaxedDep where+    parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)++-- continuation after *+relaxedDepStarP :: CabalParsing m => m RelaxedDep+relaxedDepStarP =+    RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)++-- continuation after package identifier+relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep+relaxedDepPkgidP pid@(PackageIdentifier pn v)+    | pn == mkPackageName "all"+    , v == nullVersion+    =  RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)++    | v == nullVersion+    = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec+    <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))++    | otherwise+    = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec++modP :: P.CharParsing m => m RelaxDepMod+modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone++instance Pretty RelaxDepSubject where+  pretty RelaxDepSubjectAll      = Disp.text "*"+  pretty (RelaxDepSubjectPkg pn) = pretty pn++instance Parsec RelaxDepSubject where+  parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn+    where+      pkgn = do+          pn <- parsec+          pure $ if pn == mkPackageName "all"+              then RelaxDepSubjectAll+              else RelaxDepSubjectPkg pn++instance Pretty RelaxDeps where+  pretty rd | not (isRelaxDeps rd) = Disp.text "none"+  pretty (RelaxDepsSome pkgs)      = Disp.fsep .+                                   Disp.punctuate Disp.comma .+                                   map pretty $ pkgs+  pretty RelaxDepsAll              = Disp.text "all"++-- |+--+-- >>> simpleParsec "all" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "none" :: Maybe RelaxDeps+-- Just (RelaxDepsSome [])+--+-- >>> simpleParsec "*, *" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "*:*" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps+-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])+--+-- This is not a glitch, even it looks like:+--+-- >>> simpleParsec ", all" :: Maybe RelaxDeps+-- Just RelaxDepsAll+--+-- >>> simpleParsec "" :: Maybe RelaxDeps+-- Nothing+--+instance Parsec RelaxDeps where+    parsec = do+        xs <- parsecLeadingCommaNonEmpty parsec+        pure $ case toList xs of+            [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]+                -> RelaxDepsAll+            [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]+                | pn == mkPackageName "none"+                -> mempty+            xs' -> mkRelaxDepSome xs'++instance Binary RelaxDeps+instance Binary RelaxDepMod+instance Binary RelaxDepScope+instance Binary RelaxDepSubject+instance Binary RelaxedDep+instance Binary AllowNewer+instance Binary AllowOlder++instance Structured RelaxDeps+instance Structured RelaxDepMod+instance Structured RelaxDepScope+instance Structured RelaxDepSubject+instance Structured RelaxedDep+instance Structured AllowNewer+instance Structured AllowOlder++-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations+--+-- Equivalent to @isRelaxDeps = (/= 'mempty')@+isRelaxDeps :: RelaxDeps -> Bool+isRelaxDeps (RelaxDepsSome [])    = False+isRelaxDeps (RelaxDepsSome (_:_)) = True+isRelaxDeps RelaxDepsAll          = True++-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.+mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps+mkRelaxDepSome xs+    | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs+    = RelaxDepsAll++    | otherwise+    = RelaxDepsSome xs++-- | 'RelaxDepsAll' is the /absorbing element/+instance Semigroup RelaxDeps where+    -- identity element+    RelaxDepsSome []    <> r                   = r+    l@(RelaxDepsSome _) <> RelaxDepsSome []    = l+    -- absorbing element+    l@RelaxDepsAll      <> _                   = l+    (RelaxDepsSome   _) <> r@RelaxDepsAll      = r+    -- combining non-{identity,absorbing} elements+    (RelaxDepsSome   a) <> (RelaxDepsSome b)   = RelaxDepsSome (a ++ b)++-- | @'RelaxDepsSome' []@ is the /identity element/+instance Monoid RelaxDeps where+  mempty  = RelaxDepsSome []+  mappend = (<>)++instance Semigroup AllowNewer where+  AllowNewer x <> AllowNewer y = AllowNewer (x <> y)++instance Semigroup AllowOlder where+  AllowOlder x <> AllowOlder y = AllowOlder (x <> y)++instance Monoid AllowNewer where+  mempty  = AllowNewer mempty+  mappend = (<>)++instance Monoid AllowOlder where+  mempty  = AllowOlder mempty+  mappend = (<>)
+ src/Distribution/Client/Types/BuildResults.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.BuildResults (+    BuildOutcome,+    BuildOutcomes,+    BuildFailure (..),+    BuildResult (..),+    TestsResult (..),+    DocsResult (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo)+import Distribution.Types.PackageId            (PackageId)+import Distribution.Types.UnitId               (UnitId)++-- | A summary of the outcome for building a single package.+--+type BuildOutcome = Either BuildFailure BuildResult++-- | A summary of the outcome for building a whole set of packages.+--+type BuildOutcomes = Map UnitId BuildOutcome++data BuildFailure = PlanningFailed+                  | DependentFailed PackageId+                  | DownloadFailed  SomeException+                  | UnpackFailed    SomeException+                  | ConfigureFailed SomeException+                  | BuildFailed     SomeException+                  | TestsFailed     SomeException+                  | InstallFailed   SomeException+  deriving (Show, Typeable, Generic)++instance Exception BuildFailure++-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only+-- the public library's 'InstalledPackageInfo' is stored here, even if+-- there were 'InstalledPackageInfo' from internal libraries.  This+-- 'InstalledPackageInfo' is not used anyway, so it makes no difference.+data BuildResult = BuildResult DocsResult TestsResult+                               (Maybe InstalledPackageInfo)+  deriving (Show, Generic)++data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+  deriving (Show, Generic, Typeable)+data TestsResult = TestsNotTried | TestsOk+  deriving (Show, Generic, Typeable)++instance Binary BuildFailure+instance Binary BuildResult+instance Binary DocsResult+instance Binary TestsResult++instance Structured BuildFailure+instance Structured BuildResult+instance Structured DocsResult+instance Structured TestsResult
+ src/Distribution/Client/Types/ConfiguredId.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.ConfiguredId (+    InstalledPackageId,+    ConfiguredId (..),+    annotatedIdToConfiguredId,+    HasConfiguredId (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId)+import Distribution.Package              (Package (..))+import Distribution.Types.AnnotatedId    (AnnotatedId (..))+import Distribution.Types.ComponentId    (ComponentId)+import Distribution.Types.ComponentName  (ComponentName)+import Distribution.Types.PackageId      (PackageId)++-------------------------------------------------------------------------------+-- InstalledPackageId+-------------------------------------------------------------------------------++-- | Within Cabal the library we no longer have a @InstalledPackageId@ type.+-- That's because it deals with the compilers' notion of a registered library,+-- and those really are libraries not packages. Those are now named units.+--+-- The package management layer does however deal with installed packages, as+-- whole packages not just as libraries. So we do still need a type for+-- installed package ids. At the moment however we track instaled packages via+-- their primary library, which is a unit id. In future this may change+-- slightly and we may distinguish these two types and have an explicit+-- conversion when we register units with the compiler.+--+type InstalledPackageId = ComponentId++-------------------------------------------------------------------------------+-- ConfiguredId+-------------------------------------------------------------------------------++-- | A ConfiguredId is a package ID for a configured package.+--+-- Once we configure a source package we know its UnitId. It is still+-- however useful in lots of places to also know the source ID for the package.+-- We therefore bundle the two.+--+-- An already installed package of course is also "configured" (all its+-- configuration parameters and dependencies have been specified).+data ConfiguredId = ConfiguredId {+    confSrcId  :: PackageId+  , confCompName :: Maybe ComponentName+  , confInstId :: ComponentId+  }+  deriving (Eq, Ord, Generic)++annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId+annotatedIdToConfiguredId aid = ConfiguredId {+        confSrcId    = ann_pid aid,+        confCompName = Just (ann_cname aid),+        confInstId   = ann_id aid+    }++instance Binary ConfiguredId+instance Structured ConfiguredId++instance Show ConfiguredId where+  show cid = show (confInstId cid)++instance Package ConfiguredId where+  packageId = confSrcId++-------------------------------------------------------------------------------+-- HasConfiguredId class+-------------------------------------------------------------------------------++class HasConfiguredId a where+    configuredId :: a -> ConfiguredId++-- NB: This instance is slightly dangerous, in that you'll lose+-- information about the specific UnitId you depended on.+instance HasConfiguredId InstalledPackageInfo where+    configuredId ipkg = ConfiguredId (packageId ipkg)+                            (Just (sourceComponentName ipkg))+                            (installedComponentId ipkg)
+ src/Distribution/Client/Types/ConfiguredPackage.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies  #-}+module Distribution.Client.Types.ConfiguredPackage (+    ConfiguredPackage (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Compat.Graph (IsNode (..))+import Distribution.Package      (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId)+import Distribution.Types.Flag   (FlagAssignment)+import Distribution.Types.ComponentName+import Distribution.Types.LibraryName (LibraryName (..))+import Distribution.Types.MungedPackageId (computeCompatPackageId)+import Distribution.Simple.Utils (ordNub)++import Distribution.Client.Types.ConfiguredId+import Distribution.Solver.Types.OptionalStanza   (OptionalStanzaSet)+import Distribution.Solver.Types.PackageFixedDeps+import Distribution.Solver.Types.SourcePackage    (SourcePackage)++import qualified Distribution.Solver.Types.ComponentDeps as CD++-- | A 'ConfiguredPackage' is a not-yet-installed package along with the+-- total configuration information. The configuration information is total in+-- the sense that it provides all the configuration information and so the+-- final configure process will be independent of the environment.+--+-- 'ConfiguredPackage' is assumed to not support Backpack.  Only the+-- @v2-build@ codepath supports Backpack.+--+data ConfiguredPackage loc = ConfiguredPackage+    { confPkgId      :: InstalledPackageId+    , confPkgSource  :: SourcePackage loc  -- ^ package info, including repo+    , confPkgFlags   :: FlagAssignment     -- ^ complete flag assignment for the package+    , confPkgStanzas :: OptionalStanzaSet  -- ^ list of enabled optional stanzas for the package+    , confPkgDeps    :: CD.ComponentDeps [ConfiguredId]+      -- ^ set of exact dependencies (installed or source).+      --+      -- These must be consistent with the 'buildDepends'+      -- in the 'PackageDescription' that you'd get by+      -- applying the flag assignment and optional stanzas.+    }+  deriving (Eq, Show, Generic)++-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.+-- This type class is mostly used to conveniently finesse between+-- 'ElaboratedPackage' and 'ElaboratedComponent'.+--+instance HasConfiguredId (ConfiguredPackage loc) where+    configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg)++-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed+-- to never have a nontrivial 'UnitId'+instance PackageFixedDeps (ConfiguredPackage loc) where+    depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps++instance IsNode (ConfiguredPackage loc) where+    type Key (ConfiguredPackage loc) = UnitId+    nodeKey       = newSimpleUnitId . confPkgId+    -- TODO: if we update ConfiguredPackage to support order-only+    -- dependencies, need to include those here.+    -- NB: have to deduplicate, otherwise the planner gets confused+    nodeNeighbors = ordNub . CD.flatDeps . depends++instance (Binary loc) => Binary (ConfiguredPackage loc)+++++instance Package (ConfiguredPackage loc) where+  packageId cpkg = packageId (confPkgSource cpkg)++instance HasMungedPackageId (ConfiguredPackage loc) where+  mungedId cpkg = computeCompatPackageId (packageId cpkg) LMainLibName++-- Never has nontrivial UnitId+instance HasUnitId (ConfiguredPackage loc) where+  installedUnitId = newSimpleUnitId . confPkgId++instance PackageInstalled (ConfiguredPackage loc) where+  installedDepends = CD.flatDeps . depends+++
+ src/Distribution/Client/Types/Credentials.hs view
@@ -0,0 +1,9 @@+module Distribution.Client.Types.Credentials (+    Username (..),+    Password (..),+) where++import Prelude (String)++newtype Username = Username { unUsername :: String }+newtype Password = Password { unPassword :: String }
+ src/Distribution/Client/Types/InstallMethod.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.InstallMethod where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as PP++data InstallMethod+    = InstallMethodCopy+    | InstallMethodSymlink+  deriving (Eq, Show, Generic, Bounded, Enum)++instance Binary InstallMethod+instance Structured InstallMethod++-- | Last+instance Semigroup InstallMethod where+    _ <> x = x++instance Parsec InstallMethod where+    parsec = do+        name <- P.munch1 isAlpha+        case name of+            "copy"    -> pure InstallMethodCopy+            "symlink" -> pure InstallMethodSymlink+            _         -> P.unexpected $ "InstallMethod: " ++ name++instance Pretty InstallMethod where+    pretty InstallMethodCopy    = PP.text "copy"+    pretty InstallMethodSymlink = PP.text "symlink"
+ src/Distribution/Client/Types/OverwritePolicy.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.OverwritePolicy where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as PP++data OverwritePolicy+    = NeverOverwrite+    | AlwaysOverwrite+  deriving (Show, Eq, Generic, Bounded, Enum)++instance Binary OverwritePolicy+instance Structured OverwritePolicy++instance Parsec OverwritePolicy where+    parsec = do+        name <- P.munch1 isAlpha+        case name of+            "always" -> pure AlwaysOverwrite+            "never"  -> pure NeverOverwrite+            _        -> P.unexpected $ "OverwritePolicy: " ++ name++instance Pretty OverwritePolicy where+    pretty NeverOverwrite  = PP.text "never"+    pretty AlwaysOverwrite = PP.text "always"
+ src/Distribution/Client/Types/PackageLocation.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.PackageLocation (+    PackageLocation (..),+    UnresolvedPkgLoc,+    ResolvedPkgLoc,+    UnresolvedSourcePackage,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Network.URI (URI)++import Distribution.Types.PackageId (PackageId)++import Distribution.Client.Types.Repo+import Distribution.Client.Types.SourceRepo    (SourceRepoMaybe)+import Distribution.Solver.Types.SourcePackage (SourcePackage)++type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)++type ResolvedPkgLoc = PackageLocation FilePath++data PackageLocation local =++    -- | An unpacked package in the given dir, or current dir+    LocalUnpackedPackage FilePath++    -- | A package as a tarball that's available as a local tarball+  | LocalTarballPackage FilePath++    -- | A package as a tarball from a remote URI+  | RemoteTarballPackage URI local++    -- | A package available as a tarball from a repository.+    --+    -- It may be from a local repository or from a remote repository, with a+    -- locally cached copy. ie a package available from hackage+  | RepoTarballPackage Repo PackageId local++    -- | A package available from a version control system source repository+  | RemoteSourceRepoPackage SourceRepoMaybe local+  deriving (Show, Functor, Eq, Ord, Generic, Typeable)++instance Binary local => Binary (PackageLocation local)+instance Structured local => Structured (PackageLocation local)++-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'.+type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc
+ src/Distribution/Client/Types/PackageSpecifier.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.PackageSpecifier (+    PackageSpecifier (..),+    pkgSpecifierTarget,+    pkgSpecifierConstraints,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Package           (Package (..), packageName, packageVersion)+import Distribution.Types.PackageName (PackageName)+import Distribution.Version           (thisVersion)++import Distribution.Solver.Types.ConstraintSource+import Distribution.Solver.Types.LabeledPackageConstraint+import Distribution.Solver.Types.PackageConstraint++-- | A fully or partially resolved reference to a package.+--+data PackageSpecifier pkg =++     -- | A partially specified reference to a package (either source or+     -- installed). It is specified by package name and optionally some+     -- required properties. Use a dependency resolver to pick a specific+     -- package satisfying these properties.+     --+     NamedPackage PackageName [PackageProperty]++     -- | A fully specified source package.+     --+   | SpecificSourcePackage pkg+  deriving (Eq, Show, Functor, Generic)++instance Binary pkg => Binary (PackageSpecifier pkg)+instance Structured pkg => Structured (PackageSpecifier pkg)++pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName+pkgSpecifierTarget (NamedPackage name _)       = name+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg++pkgSpecifierConstraints :: Package pkg+                        => PackageSpecifier pkg -> [LabeledPackageConstraint]+pkgSpecifierConstraints (NamedPackage name props) = map toLpc props+  where+    toLpc prop = LabeledPackageConstraint+                 (PackageConstraint (scopeToplevel name) prop)+                 ConstraintSourceUserTarget+pkgSpecifierConstraints (SpecificSourcePackage pkg)  =+    [LabeledPackageConstraint pc ConstraintSourceUserTarget]+  where+    pc = PackageConstraint+         (ScopeTarget $ packageName pkg)+         (PackagePropertyVersion $ thisVersion (packageVersion pkg))
+ src/Distribution/Client/Types/ReadyPackage.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Distribution.Client.Types.ReadyPackage (+    GenericReadyPackage (..),+    ReadyPackage,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Compat.Graph (IsNode (..))+import Distribution.Package      (HasMungedPackageId, HasUnitId, Package, PackageInstalled)++import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage)+import Distribution.Client.Types.PackageLocation   (UnresolvedPkgLoc)+import Distribution.Solver.Types.PackageFixedDeps++-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be+-- installed already, hence itself ready to be installed.+newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.+  deriving (Eq, Show, Generic, Package, PackageFixedDeps,+            HasMungedPackageId, HasUnitId, PackageInstalled, Binary)++-- Can't newtype derive this+instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where+    type Key (GenericReadyPackage srcpkg) = Key srcpkg+    nodeKey (ReadyPackage spkg) = nodeKey spkg+    nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg++type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
+ src/Distribution/Client/Types/Repo.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.Repo (+    -- * Remote repository+    RemoteRepo (..),+    emptyRemoteRepo,+    -- * Local repository (no-index)+    LocalRepo (..),+    emptyLocalRepo,+    localRepoCacheKey,+    -- * Repository+    Repo (..),+    repoName,+    isRepoRemote,+    maybeRepoRemote,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString)++import Distribution.Simple.Utils (toUTF8BS)++import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)++import qualified Data.ByteString.Lazy.Char8      as LBS+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++import Distribution.Client.Types.RepoName++-------------------------------------------------------------------------------+-- Remote repository+-------------------------------------------------------------------------------++data RemoteRepo =+    RemoteRepo {+      remoteRepoName     :: RepoName,+      remoteRepoURI      :: URI,++      -- | Enable secure access?+      --+      -- 'Nothing' here represents "whatever the default is"; this is important+      -- to allow for a smooth transition from opt-in to opt-out security+      -- (once we switch to opt-out, all access to the central Hackage+      -- repository should be secure by default)+      remoteRepoSecure :: Maybe Bool,++      -- | Root key IDs (for bootstrapping)+      remoteRepoRootKeys :: [String],++      -- | Threshold for verification during bootstrapping+      remoteRepoKeyThreshold :: Int,++      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a+      -- special case we may know a repo supports both and want to try HTTPS+      -- if we can, but still allow falling back to HTTP.+      --+      -- This field is not currently stored in the config file, but is filled+      -- in automagically for known repos.+      remoteRepoShouldTryHttps :: Bool+    }++  deriving (Show, Eq, Ord, Generic)++instance Binary RemoteRepo+instance Structured RemoteRepo++instance Pretty RemoteRepo where+    pretty r =+        pretty (remoteRepoName r) <<>> Disp.colon <<>>+        Disp.text (uriToString id (remoteRepoURI r) [])++-- | Note: serialised format represends 'RemoteRepo' only partially.+instance Parsec RemoteRepo where+    parsec = do+        name <- parsec+        _ <- P.char ':'+        uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))+        uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)+        return RemoteRepo+            { remoteRepoName           = name+            , remoteRepoURI            = uri+            , remoteRepoSecure         = Nothing+            , remoteRepoRootKeys       = []+            , remoteRepoKeyThreshold   = 0+            , remoteRepoShouldTryHttps = False+            }++-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.+emptyRemoteRepo :: RepoName -> RemoteRepo+emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False++-------------------------------------------------------------------------------+-- Local repository+-------------------------------------------------------------------------------++-- | /no-index/ style local repositories.+--+-- https://github.com/haskell/cabal/issues/6359+data LocalRepo = LocalRepo+    { localRepoName        :: RepoName+    , localRepoPath        :: FilePath+    , localRepoSharedCache :: Bool+    }+  deriving (Show, Eq, Ord, Generic)++instance Binary LocalRepo+instance Structured LocalRepo++-- | Note: doesn't parse 'localRepoSharedCache' field.+instance Parsec LocalRepo where+    parsec = do+        n <- parsec+        _ <- P.char ':'+        p <- P.munch1 (const True) -- restrict what can be a path?+        return (LocalRepo n p False)++instance Pretty LocalRepo where+    pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p++-- | Construct a partial 'LocalRepo' value to fold the field parser list over.+emptyLocalRepo :: RepoName -> LocalRepo+emptyLocalRepo name = LocalRepo name "" False++-- | Calculate a cache key for local-repo.+--+-- For remote repositories we just use name, but local repositories may+-- all be named "local", so we add a bit of `localRepoPath` into the+-- mix.+localRepoCacheKey :: LocalRepo -> String+localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where+    hashPart+        = showHashValue $ truncateHash 8 $ hashValue+        $ LBS.fromStrict $ toUTF8BS $ localRepoPath local++-------------------------------------------------------------------------------+-- Any repository+-------------------------------------------------------------------------------++-- | Different kinds of repositories+--+-- NOTE: It is important that this type remains serializable.+data Repo+    -- | Local repository, without index.+    --+    -- https://github.com/haskell/cabal/issues/6359+  = RepoLocalNoIndex+      { repoLocal    :: LocalRepo+      , repoLocalDir :: FilePath+      }++    -- | Standard (unsecured) remote repositores+  | RepoRemote {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }++    -- | Secure repositories+    --+    -- Although this contains the same fields as 'RepoRemote', we use a separate+    -- constructor to avoid confusing the two.+    --+    -- Not all access to a secure repo goes through the hackage-security+    -- library currently; code paths that do not still make use of the+    -- 'repoRemote' and 'repoLocalDir' fields directly.+  | RepoSecure {+        repoRemote   :: RemoteRepo+      , repoLocalDir :: FilePath+      }+  deriving (Show, Eq, Ord, Generic)++instance Binary Repo+instance Structured Repo++-- | Check if this is a remote repo+isRepoRemote :: Repo -> Bool+isRepoRemote RepoLocalNoIndex{} = False+isRepoRemote _                  = True++-- | Extract @RemoteRepo@ from @Repo@ if remote.+maybeRepoRemote :: Repo -> Maybe RemoteRepo+maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing+maybeRepoRemote (RepoRemote       r _localDir) = Just r+maybeRepoRemote (RepoSecure       r _localDir) = Just r++repoName :: Repo -> RepoName+repoName (RepoLocalNoIndex r _) = localRepoName r+repoName (RepoRemote r _)       = remoteRepoName r+repoName (RepoSecure r _)       = remoteRepoName r
+ src/Distribution/Client/Types/RepoName.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.RepoName (+    RepoName (..),+    unRepoName,+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint                as Disp++-- $setup+-- >>> import Distribution.Parsec++-- | Repository name.+--+-- May be used as path segment.+--+newtype RepoName = RepoName String+  deriving (Show, Eq, Ord, Generic)++unRepoName :: RepoName -> String+unRepoName (RepoName n) = n++instance Binary RepoName+instance Structured RepoName+instance NFData RepoName++instance Pretty RepoName where+    pretty = Disp.text . unRepoName++-- |+--+-- >>> simpleParsec "hackage.haskell.org" :: Maybe RepoName+-- Just (RepoName "hackage.haskell.org")+--+-- >>> simpleParsec "0123" :: Maybe RepoName+-- Nothing+--+instance Parsec RepoName where+    parsec = RepoName <$> parser where+        parser = (:) <$> lead <*> rest+        lead = P.satisfy (\c -> isAlpha    c || c == '_' || c == '-' || c == '.')+        rest = P.munch   (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
+ src/Distribution/Client/Types/SourcePackageDb.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.SourcePackageDb (+    SourcePackageDb (..),+) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import Distribution.Types.PackageName  (PackageName)+import Distribution.Types.VersionRange (VersionRange)++import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage)+import Distribution.Solver.Types.PackageIndex    (PackageIndex)++-- | This is the information we get from a @00-index.tar.gz@ hackage index.+--+data SourcePackageDb = SourcePackageDb+    { packageIndex       :: PackageIndex UnresolvedSourcePackage+    , packagePreferences :: Map PackageName VersionRange+    }+  deriving (Eq, Generic)++instance Binary SourcePackageDb
+ src/Distribution/Client/Types/SourceRepo.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE UndecidableInstances #-}+module Distribution.Client.Types.SourceRepo (+    SourceRepositoryPackage (..),+    SourceRepoList,+    SourceRepoMaybe,+    SourceRepoProxy,+    srpHoist,+    srpToProxy,+    srpFanOut,+    sourceRepositoryPackageGrammar,+) where++import Distribution.Client.Compat.Prelude+import Distribution.Compat.Lens           (Lens, Lens')+import Prelude ()++import Distribution.FieldGrammar+import Distribution.Types.SourceRepo (RepoType (..))++-- | @source-repository-package@ definition+--+data SourceRepositoryPackage f = SourceRepositoryPackage+    { srpType     :: !RepoType+    , srpLocation :: !String+    , srpTag      :: !(Maybe String)+    , srpBranch   :: !(Maybe String)+    , srpSubdir   :: !(f FilePath)+    , srpCommand  :: ![String]+    }+  deriving (Generic)++deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)+deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)+deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)+deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)+deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)++-- | Read from @cabal.project@+type SourceRepoList  = SourceRepositoryPackage []++-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'+type SourceRepoMaybe = SourceRepositoryPackage Maybe++-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.+type SourceRepoProxy = SourceRepositoryPackage Proxy++srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g+srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }++srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy+srpToProxy s = s { srpSubdir = Proxy }++-- | Split single @source-repository-package@ declaration with multiple subdirs,+-- into multiple ones with at most single subdir.+srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)+srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =+    s { srpSubdir = Nothing } :| []+srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where+    f subdir = s { srpSubdir = Just subdir }++-------------------------------------------------------------------------------+-- Lens+-------------------------------------------------------------------------------++srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType+srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))+{-# INLINE srpTypeLens #-}++srpLocationLens :: Lens' (SourceRepositoryPackage f) String+srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))+{-# INLINE srpLocationLens #-}++srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)+srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))+{-# INLINE srpTagLens #-}++srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)+srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))+{-# INLINE srpBranchLens #-}++srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)+srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))+{-# INLINE srpSubdirLens #-}++srpCommandLensNE :: Lens' (SourceRepositoryPackage f) (Maybe (NonEmpty String))+srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (nonEmpty (srpCommand s)))+{-# INLINE srpCommandLensNE #-}++-------------------------------------------------------------------------------+-- Parser & PPrinter+-------------------------------------------------------------------------------++sourceRepositoryPackageGrammar+    :: ( FieldGrammar c g, Applicative (g SourceRepoList)+       , c (Identity RepoType)+       , c (List NoCommaFSep FilePathNT String)+       , c (NonEmpty' NoCommaFSep Token String)+       )+    => g SourceRepoList SourceRepoList+sourceRepositoryPackageGrammar = SourceRepositoryPackage+    <$> uniqueField      "type"                                       srpTypeLens+    <*> uniqueFieldAla   "location" Token                             srpLocationLens+    <*> optionalFieldAla "tag"      Token                             srpTagLens+    <*> optionalFieldAla "branch"   Token                             srpBranchLens+    <*> monoidalFieldAla "subdir"   (alaList' NoCommaFSep FilePathNT) srpSubdirLens  -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...+    <*> fmap (maybe [] toList) pcc+  where+    pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE+{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}+{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}
+ src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (+    WriteGhcEnvironmentFilesPolicy (..),+) where++import Prelude ()+import Distribution.Client.Compat.Prelude++-- | Whether 'v2-build' should write a .ghc.environment file after+-- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+'+-- (8.4.4 is the earliest version that supports+-- '-package-env -').+data WriteGhcEnvironmentFilesPolicy+  = AlwaysWriteGhcEnvironmentFiles+  | NeverWriteGhcEnvironmentFiles+  | WriteGhcEnvironmentFilesOnlyForGhc844AndNewer+  deriving (Eq, Enum, Bounded, Generic, Show)++instance Binary WriteGhcEnvironmentFilesPolicy+instance Structured WriteGhcEnvironmentFilesPolicy
+ src/Distribution/Client/Upload.hs view
@@ -0,0 +1,225 @@+module Distribution.Client.Upload (upload, uploadDoc, report) where++import Distribution.Client.Compat.Prelude+import qualified Prelude as Unsafe (tail, head, read)++import Distribution.Client.Types.Credentials ( Username(..), Password(..) )+import Distribution.Client.Types.Repo (RemoteRepo(..), maybeRepoRemote)+import Distribution.Client.Types.RepoName (unRepoName)+import Distribution.Client.HttpUtils+         ( HttpTransport(..), remoteRepoTryUpgradeToHttps )+import Distribution.Client.Setup+         ( IsCandidate(..), RepoContext(..) )++import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS)+import Distribution.Client.Config++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (parseBuildReport)+import qualified Distribution.Client.BuildReports.Upload as BuildReport++import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName))+import Network.HTTP (Header(..), HeaderName(..))++import System.IO        (hFlush, stdout)+import System.IO.Echo   (withoutInputEcho)+import System.FilePath  ((</>), takeExtension, takeFileName, dropExtension)+import qualified System.FilePath.Posix as FilePath.Posix ((</>))+import System.Directory++type Auth = Maybe (String, String)++-- > stripExtensions ["tar", "gz"] "foo.tar.gz"+-- Just "foo"+-- > stripExtensions ["tar", "gz"] "foo.gz.tar"+-- Nothing+stripExtensions :: [String] -> FilePath -> Maybe String+stripExtensions exts path = foldM f path (reverse exts)+ where+  f p e+    | takeExtension p == '.':e = Just (dropExtension p)+    | otherwise = Nothing++upload :: Verbosity -> RepoContext+       -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]+       -> IO ()+upload verbosity repoCtxt mUsername mPassword isCandidate paths = do+    let repos = repoContextRepos repoCtxt+    transport  <- repoContextGetTransport repoCtxt+    targetRepo <-+      case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of+        [] -> die' verbosity "Cannot upload. No remote repositories are configured."+        (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))+    let targetRepoURI = remoteRepoURI targetRepo+        domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI+        rootIfEmpty x = if null x then "/" else x+        uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>+              case isCandidate of+                IsCandidate -> "packages/candidates"+                IsPublished -> "upload"+        }+        packageURI pkgid = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                  IsCandidate -> "/candidate"+                  IsPublished -> ""+              ]+        }+    Username username <- maybe (promptUsername domain) return mUsername+    Password password <- maybe (promptPassword domain) return mPassword+    let auth = Just (username,password)+    for_ paths $ \path -> do+      notice verbosity $ "Uploading " ++ path ++ "... "+      case fmap takeFileName (stripExtensions ["tar", "gz"] path) of+        Just pkgid -> handlePackage transport verbosity uploadURI+                                    (packageURI pkgid) auth isCandidate path+        -- This case shouldn't really happen, since we check in Main that we+        -- only pass tar.gz files to upload.+        Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path++uploadDoc :: Verbosity -> RepoContext+          -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath+          -> IO ()+uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do+    let repos = repoContextRepos repoCtxt+    transport  <- repoContextGetTransport repoCtxt+    targetRepo <-+      case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of+        [] -> die' verbosity $ "Cannot upload. No remote repositories are configured."+        (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))+    let targetRepoURI = remoteRepoURI targetRepo+        domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI+        rootIfEmpty x = if null x then "/" else x+        uploadURI = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                IsCandidate -> "/candidate"+                IsPublished -> ""+              , "/docs"+              ]+        }+        packageUri = targetRepoURI {+            uriPath = rootIfEmpty (uriPath targetRepoURI)+                      FilePath.Posix.</> concat+              [ "package/", pkgid+              , case isCandidate of+                  IsCandidate -> "/candidate"+                  IsPublished -> ""+              ]+        }+        (reverseSuffix, reversePkgid) = break (== '-')+                                        (reverse (takeFileName path))+        pkgid = reverse $ Unsafe.tail reversePkgid+    when (reverse reverseSuffix /= "docs.tar.gz"+          || null reversePkgid || Unsafe.head reversePkgid /= '-') $+      die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"+    Username username <- maybe (promptUsername domain) return mUsername+    Password password <- maybe (promptPassword domain) return mPassword++    let auth = Just (username,password)+        headers =+          [ Header HdrContentType "application/x-tar"+          , Header HdrContentEncoding "gzip"+          ]+    notice verbosity $ "Uploading documentation " ++ path ++ "... "+    resp <- putHttpFile transport verbosity uploadURI path auth headers+    case resp of+      -- Hackage responds with 204 No Content when docs are uploaded+      -- successfully.+      (code,_) | code `elem` [200,204] -> do+        notice verbosity $ okMessage packageUri+      (code,err)  -> do+        notice verbosity $ "Error uploading documentation "+                        ++ path ++ ": "+                        ++ "http code " ++ show code ++ "\n"+                        ++ err+        exitFailure+  where+    okMessage packageUri = case isCandidate of+      IsCandidate ->+        "Documentation successfully uploaded for package candidate. "+        ++ "You can now preview the result at '" ++ show packageUri+        ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'."+      IsPublished ->+        "Package documentation successfully published. You can now view it at '"+        ++ show packageUri ++ "'."+++promptUsername :: String -> IO Username+promptUsername domain = do+  putStr $ domain ++ " username: "+  hFlush stdout+  fmap Username getLine++promptPassword :: String -> IO Password+promptPassword domain = do+  putStr $ domain ++ " password: "+  hFlush stdout+  -- save/restore the terminal echoing status (no echoing for entering the password)+  passwd <- withoutInputEcho $ fmap Password getLine+  putStrLn ""+  return passwd++report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO ()+report verbosity repoCtxt mUsername mPassword = do+  let repos       = repoContextRepos repoCtxt+      remoteRepos = mapMaybe maybeRepoRemote repos+  for_ remoteRepos $ \remoteRepo -> do+      let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)+      Username username <- maybe (promptUsername domain) return mUsername+      Password password <- maybe (promptPassword domain) return mPassword+      let auth        = (username, password)++      dotCabal <- getCabalDir+      let srcDir = dotCabal </> "reports" </> unRepoName (remoteRepoName remoteRepo)+      -- We don't want to bomb out just because we haven't built any packages+      -- from this repo yet.+      srcExists <- doesDirectoryExist srcDir+      when srcExists $ do+        contents <- getDirectoryContents srcDir+        for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->+          do inp <- readFile (srcDir </> logFile)+             let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse+             case parseBuildReport (toUTF8BS reportStr) of+               Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME+               Right report' ->+                 do info verbosity $ "Uploading report for "+                      ++ prettyShow (BuildReport.package report')+                    BuildReport.uploadReports verbosity repoCtxt auth+                      (remoteRepoURI remoteRepo) [(report', Just buildLog)]+                    return ()++handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth+              -> IsCandidate -> FilePath -> IO ()+handlePackage transport verbosity uri packageUri auth isCandidate path =+  do resp <- postHttpFile transport verbosity uri path auth+     case resp of+       (code,warnings) | code `elem` [200, 204] ->+          notice verbosity $ okMessage isCandidate +++            if null warnings then "" else "\n" ++ formatWarnings (trim warnings)+       (code,err)  -> do+          notice verbosity $ "Error uploading " ++ path ++ ": "+                          ++ "http code " ++ show code ++ "\n"+                          ++ err+          exitFailure+ where+  okMessage IsCandidate =+    "Package successfully uploaded as candidate. "+    ++ "You can now preview the result at '" ++ show packageUri+    ++ "'. To publish the candidate, use 'cabal upload --publish'."+  okMessage IsPublished =+    "Package successfully published. You can now view it at '"+    ++ show packageUri ++ "'."++formatWarnings :: String -> String+formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x++-- Trim+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace
+ src/Distribution/Client/Utils.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}++module Distribution.Client.Utils ( MergeResult(..)+                                 , mergeBy, duplicates, duplicatesBy+                                 , readMaybe+                                 , inDir, withEnv, withEnvOverrides+                                 , logDirChange, withExtraPathEnv+                                 , determineNumJobs, numberOfProcessors+                                 , removeExistingFile+                                 , withTempFileName+                                 , makeAbsoluteToCwd+                                 , makeRelativeToCwd, makeRelativeToDir+                                 , makeRelativeCanonical+                                 , filePathToByteString+                                 , byteStringToFilePath, tryCanonicalizePath+                                 , canonicalizePathNoThrow+                                 , moreRecentFile, existsAndIsMoreRecentThan+                                 , tryFindAddSourcePackageDesc+                                 , tryFindPackageDesc+                                 , relaxEncodingErrors+                                 , ProgressPhase (..)+                                 , progressMessage+                                 , cabalInstallVersion)+       where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Compat.Environment+import Distribution.Compat.Time        ( getModTime )+import Distribution.Simple.Setup       ( Flag(..) )+import Distribution.Version+import Distribution.Simple.Utils       ( die', findPackageDesc, noticeNoWrap )+import qualified Data.ByteString.Lazy as BS+import Data.Bits+         ( (.|.), shiftL, shiftR )+import System.FilePath+import Control.Monad+         ( zipWithM_ )+import Data.List+         ( groupBy )+import Foreign.C.Types ( CInt(..) )+import qualified Control.Exception as Exception+         ( finally, bracket )+import System.Directory+         ( canonicalizePath, doesFileExist, getCurrentDirectory+         , removeFile, setCurrentDirectory )+import System.IO+         ( Handle, hClose, openTempFile+         , hGetEncoding, hSetEncoding+         )+import System.IO.Unsafe ( unsafePerformIO )++import GHC.IO.Encoding+         ( recover, TextEncoding(TextEncoding) )+import GHC.IO.Encoding.Failure+         ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )++#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)+import qualified System.Directory as Dir+import qualified System.IO.Error as IOError+#endif++#ifndef __DOCTEST__+import qualified Paths_cabal_install (version)+#endif++-- | Generic merging utility. For sorted input lists this is a full outer join.+--+mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]+mergeBy cmp = merge+  where+    merge []     ys     = [ OnlyInRight y | y <- ys]+    merge xs     []     = [ OnlyInLeft  x | x <- xs]+    merge (x:xs) (y:ys) =+      case x `cmp` y of+        GT -> OnlyInRight   y : merge (x:xs) ys+        EQ -> InBoth      x y : merge xs     ys+        LT -> OnlyInLeft  x   : merge xs  (y:ys)++data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b++duplicates :: Ord a => [a] -> [[a]]+duplicates = duplicatesBy compare++duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]+duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp+  where+    eq a b = case cmp a b of+               EQ -> True+               _  -> False+    moreThanOne (_:_:_) = True+    moreThanOne _       = False++-- | Like 'removeFile', but does not throw an exception when the file does not+-- exist.+removeExistingFile :: FilePath -> IO ()+removeExistingFile path = do+  exists <- doesFileExist path+  when exists $+    removeFile path++-- | A variant of 'withTempFile' that only gives us the file name, and while+-- it will clean up the file afterwards, it's lenient if the file is+-- moved\/deleted.+--+withTempFileName :: FilePath+                 -> String+                 -> (FilePath -> IO a) -> IO a+withTempFileName tmpDir template action =+  Exception.bracket+    (openTempFile tmpDir template)+    (\(name, _) -> removeExistingFile name)+    (\(name, h) -> hClose h >> action name)++-- | Executes the action in the specified directory.+--+-- Warning: This operation is NOT thread-safe, because current+-- working directory is a process-global concept.+inDir :: Maybe FilePath -> IO a -> IO a+inDir Nothing m = m+inDir (Just d) m = do+  old <- getCurrentDirectory+  setCurrentDirectory d+  m `Exception.finally` setCurrentDirectory old++-- | Executes the action with an environment variable set to some+-- value.+--+-- Warning: This operation is NOT thread-safe, because current+-- environment is a process-global concept.+withEnv :: String -> String -> IO a -> IO a+withEnv k v m = do+  mb_old <- lookupEnv k+  setEnv k v+  m `Exception.finally` (case mb_old of+    Nothing -> unsetEnv k+    Just old -> setEnv k old)++-- | Executes the action with a list of environment variables and+-- corresponding overrides, where+--+-- * @'Just' v@ means \"set the environment variable's value to @v@\".+-- * 'Nothing' means \"unset the environment variable\".+--+-- Warning: This operation is NOT thread-safe, because current+-- environment is a process-global concept.+withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a+withEnvOverrides overrides m = do+  mb_olds <- traverse lookupEnv envVars+  traverse_ (uncurry update) overrides+  m `Exception.finally` zipWithM_ update envVars mb_olds+   where+    envVars :: [String]+    envVars = map fst overrides++    update :: String -> Maybe FilePath -> IO ()+    update var Nothing    = unsetEnv var+    update var (Just val) = setEnv var val++-- | Executes the action, increasing the PATH environment+-- in some way+--+-- Warning: This operation is NOT thread-safe, because the+-- environment variables are a process-global concept.+withExtraPathEnv :: [FilePath] -> IO a -> IO a+withExtraPathEnv paths m = do+  oldPathSplit <- getSearchPath+  let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)+      oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit+      -- TODO: This is a horrible hack to work around the fact that+      -- setEnv can't take empty values as an argument+      mungePath p | p == ""   = "/dev/null"+                  | otherwise = p+  setEnv "PATH" newPath+  m `Exception.finally` setEnv "PATH" oldPath++-- | Log directory change in 'make' compatible syntax+logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a+logDirChange _ Nothing m = m+logDirChange l (Just d) m = do+  l $ "cabal: Entering directory '" ++ d ++ "'\n"+  m `Exception.finally`+    (l $ "cabal: Leaving directory '" ++ d ++ "'\n")++foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt++-- The number of processors is not going to change during the duration of the+-- program, so unsafePerformIO is safe here.+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+makeAbsoluteToCwd path | isAbsolute path = return path+                       | otherwise       = do cwd <- getCurrentDirectory+                                              return $! cwd </> path++-- | Given a path (relative or absolute), make it relative to the current+-- directory, including using @../..@ if necessary.+makeRelativeToCwd :: FilePath -> IO FilePath+makeRelativeToCwd path =+    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory++-- | Given a path (relative or absolute), make it relative to the given+-- directory, including using @../..@ if necessary.+makeRelativeToDir :: FilePath -> FilePath -> IO FilePath+makeRelativeToDir path dir =+    makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir++-- | Given a canonical absolute path and canonical absolute dir, make the path+-- relative to the directory, including using @../..@ if necessary. Returns+-- the original absolute path if it is not on the same drive as the given dir.+makeRelativeCanonical :: FilePath -> FilePath -> FilePath+makeRelativeCanonical path dir+  | takeDrive path /= takeDrive dir = path+  | otherwise                       = go (splitPath path) (splitPath dir)+  where+    go (p:ps) (d:ds) | p == d = go ps ds+    go    []     []           = "./"+    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)++-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is+-- encoded as a little-endian 'Word32'.+filePathToByteString :: FilePath -> BS.ByteString+filePathToByteString p =+  BS.pack $ foldr conv [] codepts+  where+    codepts :: [Word32]+    codepts = map (fromIntegral . ord) p++    conv :: Word32 -> [Word8] -> [Word8]+    conv w32 rest = b0:b1:b2:b3:rest+      where+        b0 = fromIntegral $ w32+        b1 = fromIntegral $ w32 `shiftR` 8+        b2 = fromIntegral $ w32 `shiftR` 16+        b3 = fromIntegral $ w32 `shiftR` 24++-- | Reverse operation to 'filePathToByteString'.+byteStringToFilePath :: BS.ByteString -> FilePath+byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected+                        | otherwise = go 0+  where+    unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"+    bslen = BS.length bs++    go i | i == bslen = []+         | otherwise = (chr . fromIntegral $ w32) : go (i+4)+      where+        w32 :: Word32+        w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)+        b0 = fromIntegral $ BS.index bs i+        b1 = fromIntegral $ BS.index bs (i + 1)+        b2 = fromIntegral $ BS.index bs (i + 2)+        b3 = fromIntegral $ BS.index bs (i + 3)++-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always+-- throws an error if the path refers to a non-existent file.+tryCanonicalizePath :: FilePath -> IO FilePath+tryCanonicalizePath path = do+  ret <- canonicalizePath path+#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)+  exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)+  unless exists $+    IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"+                        Nothing (Just ret)+#endif+  return ret++-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws+-- an exception, returns the path argument unmodified.+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++-- | Sets the handler for encoding errors to one that transliterates invalid+-- characters into one present in the encoding (i.e., \'?\').+-- This is opposed to the default behavior, which is to throw an exception on+-- error. This function will ignore file handles that have a Unicode encoding+-- set. It's a no-op for versions of `base` less than 4.4.+relaxEncodingErrors :: Handle -> IO ()+relaxEncodingErrors handle = do+  maybeEncoding <- hGetEncoding handle+  case maybeEncoding of+    Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->+      let relax x = x { recover = recoverEncode TransliterateCodingFailure }+      in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))+    _ ->+      return ()++-- |Like 'tryFindPackageDesc', but with error specific to add-source deps.+tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath+tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $+    err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "+    ++ depPath++-- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be+-- found, with @err@ prefixing the error message. This function simply allows+-- us to give a more descriptive error than that provided by @findPackageDesc@.+tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath+tryFindPackageDesc verbosity depPath err = do+    errOrCabalFile <- findPackageDesc depPath+    case errOrCabalFile of+        Right file -> return file+        Left _ -> die' verbosity err++-- | Phase of building a dependency. Represents current status of package+-- dependency processing. See #4040 for details.+data ProgressPhase+    = ProgressDownloading+    | ProgressDownloaded+    | ProgressStarting+    | ProgressBuilding+    | ProgressHaddock+    | ProgressInstalling+    | ProgressCompleted++progressMessage :: Verbosity -> ProgressPhase -> String -> IO ()+progressMessage verbosity phase subject = do+    noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n"+  where+    phaseStr = case phase of+        ProgressDownloading -> "Downloading  "+        ProgressDownloaded  -> "Downloaded   "+        ProgressStarting    -> "Starting     "+        ProgressBuilding    -> "Building     "+        ProgressHaddock     -> "Haddock      "+        ProgressInstalling  -> "Installing   "+        ProgressCompleted   -> "Completed    "++cabalInstallVersion :: Version+#ifdef __DOCTEST__+cabalInstallVersion = mkVersion [3,3]+#else+cabalInstallVersion = mkVersion' Paths_cabal_install.version+#endif
+ src/Distribution/Client/Utils/Json.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Minimal JSON / RFC 7159 support+--+-- The API is heavily inspired by @aeson@'s API but puts emphasis on+-- simplicity rather than performance. The 'ToJSON' instances are+-- intended to have an encoding compatible with @aeson@'s encoding.+--+module Distribution.Client.Utils.Json+    ( Value(..)+    , Object, object, Pair, (.=)+    , encodeToString+    , encodeToBuilder+    , ToJSON(toJSON)+    )+    where++import Distribution.Client.Compat.Prelude++import Data.Char (intToDigit)++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB++-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array  [Value]+           | String  String+           | Number !Double+           | Bool   !Bool+           | Null+           deriving (Eq, Read, Show)++-- | A key\/value pair for an 'Object'+type Pair = (String, Value)++-- | A JSON \"object\" (key/value map).+type Object = [Pair]++infixr 8 .=++-- | A key-value pair for encoding a JSON object.+(.=) :: ToJSON v => String -> v -> Pair+k .= v  = (k, toJSON v)++-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object++instance IsString Value where+  fromString = String+++-- | A type that can be converted to JSON.+class ToJSON a where+  -- | Convert a Haskell value to a JSON-friendly intermediate type.+  toJSON :: a -> Value++instance ToJSON () where+  toJSON () = Array []++instance ToJSON Value where+  toJSON = id++instance ToJSON Bool where+  toJSON = Bool++instance ToJSON a => ToJSON [a] where+  toJSON = Array . map toJSON++instance ToJSON a => ToJSON (Maybe a) where+  toJSON Nothing  = Null+  toJSON (Just a) = toJSON a++instance (ToJSON a,ToJSON b) => ToJSON (a,b) where+  toJSON (a,b) = Array [toJSON a, toJSON b]++instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]++instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]++instance ToJSON Float where+  toJSON = Number . realToFrac++instance ToJSON Double where+  toJSON = Number++instance ToJSON Int    where  toJSON = Number . realToFrac+instance ToJSON Int8   where  toJSON = Number . realToFrac+instance ToJSON Int16  where  toJSON = Number . realToFrac+instance ToJSON Int32  where  toJSON = Number . realToFrac++instance ToJSON Word   where  toJSON = Number . realToFrac+instance ToJSON Word8  where  toJSON = Number . realToFrac+instance ToJSON Word16 where  toJSON = Number . realToFrac+instance ToJSON Word32 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Int64  where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Word64 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Integer where toJSON = Number . fromInteger++------------------------------------------------------------------------------+-- 'BB.Builder'-based encoding++-- | Serialise value as JSON/UTF8-encoded 'Builder'+encodeToBuilder :: ToJSON a => a -> Builder+encodeToBuilder = encodeValueBB . toJSON++encodeValueBB :: Value -> Builder+encodeValueBB jv = case jv of+  Bool True  -> "true"+  Bool False -> "false"+  Null       -> "null"+  Number n+    | isNaN n || isInfinite n   -> encodeValueBB Null+    | Just i <- doubleToInt64 n -> BB.int64Dec i+    | otherwise                 -> BB.doubleDec n+  Array a  -> encodeArrayBB a+  String s -> encodeStringBB s+  Object o -> encodeObjectBB o++encodeArrayBB :: [Value] -> Builder+encodeArrayBB [] = "[]"+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'+  where+    go = mconcat . intersperse (BB.char8 ',') . map encodeValueBB++encodeObjectBB :: Object -> Builder+encodeObjectBB [] = "{}"+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'+  where+    go = mconcat . intersperse (BB.char8 ',') . map encPair+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x++encodeStringBB :: String -> Builder+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'+  where+    go = BB.stringUtf8 . escapeString++------------------------------------------------------------------------------+-- 'String'-based encoding++-- | Serialise value as JSON-encoded Unicode 'String'+encodeToString :: ToJSON a => a -> String+encodeToString jv = encodeValue (toJSON jv) []++encodeValue :: Value -> ShowS+encodeValue jv = case jv of+  Bool b   -> showString (if b then "true" else "false")+  Null     -> showString "null"+  Number n+    | isNaN n || isInfinite n    -> encodeValue Null+    | Just i <- doubleToInt64 n -> shows i+    | otherwise                 -> shows n+  Array a -> encodeArray a+  String s -> encodeString s+  Object o -> encodeObject o++encodeArray :: [Value] -> ShowS+encodeArray [] = showString "[]"+encodeArray jvs = ('[':) . go jvs . (']':)+  where+    go []     = id+    go [x]    = encodeValue x+    go (x:xs) = encodeValue x . (',':) . go xs++encodeObject :: Object -> ShowS+encodeObject [] = showString "{}"+encodeObject jvs = ('{':) . go jvs . ('}':)+  where+    go []          = id+    go [(l,x)]     = encodeString l . (':':) . encodeValue x+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs++encodeString :: String -> ShowS+encodeString str = ('"':) . showString (escapeString str) . ('"':)++------------------------------------------------------------------------------+-- helpers++-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not+-- representable loss-free as integral 'Int64' value.+doubleToInt64 :: Double -> Maybe Int64+doubleToInt64 x+  | fromInteger x' == x+  , x' <= toInteger (maxBound :: Int64)+  , x' >= toInteger (minBound :: Int64)+    = Just (fromIntegral x')+  | otherwise = Nothing+  where+    x' = round x++-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"+escapeString :: String -> String+escapeString s+  | not (any needsEscape s) = s+  | otherwise               = escape s+  where+    escape [] = []+    escape (x:xs) = case x of+      '\\' -> '\\':'\\':escape xs+      '"'  -> '\\':'"':escape xs+      '\b' -> '\\':'b':escape xs+      '\f' -> '\\':'f':escape xs+      '\n' -> '\\':'n':escape xs+      '\r' -> '\\':'r':escape xs+      '\t' -> '\\':'t':escape xs+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs+        | otherwise    -> c : escape xs++    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
+ src/Distribution/Client/Utils/Parsec.hs view
@@ -0,0 +1,102 @@+module Distribution.Client.Utils.Parsec (+    renderParseError,+    ) where++import Distribution.Client.Compat.Prelude+import Prelude ()+import System.FilePath                    (normalise)++import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BS8++import Distribution.Parsec       (PError (..), PWarning (..), Position (..), showPos, zeroPos)+import Distribution.Simple.Utils (fromUTF8BS)++-- | Render parse error highlighting the part of the input file.+renderParseError+    :: FilePath+    -> BS.ByteString+    -> NonEmpty PError+    -> [PWarning]+    -> String+renderParseError filepath contents errors warnings = unlines $+    [ "Errors encountered when parsing cabal file " <> filepath <> ":"+    ]+    ++ renderedErrors+    ++ renderedWarnings+  where+    filepath' = normalise filepath++    -- lines of the input file. 'lines' is taken, so they are called rows+    -- contents, line number, whether it's empty line+    rows :: [(String, Int, Bool)]+    rows = zipWith f (BS8.lines contents) [1..] where+        f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s)++    rowsZipper = listToZipper rows++    isEmptyOrComment :: String -> Bool+    isEmptyOrComment s = case dropWhile (== ' ') s of+        ""          -> True   -- empty+        ('-':'-':_) -> True   -- comment+        _           -> False++    renderedErrors   = concatMap renderError errors+    renderedWarnings = concatMap renderWarning warnings++    renderError :: PError -> [String]+    renderError (PError pos@(Position row col) msg)+        -- if position is 0:0, then it doesn't make sense to show input+        -- looks like, Parsec errors have line-feed in them+        | pos == zeroPos = msgs+        | otherwise      = msgs ++ formatInput row col+      where+        msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ]++    renderWarning :: PWarning -> [String]+    renderWarning (PWarning _ pos@(Position row col) msg)+        | pos == zeroPos = msgs+        | otherwise      = msgs ++ formatInput row col+      where+        msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ]++    -- sometimes there are (especially trailing) newlines.+    trimLF :: String -> String+    trimLF = dropWhile (== '\n') . reverse . dropWhile (== '\n') . reverse++    -- format line: prepend the given line number+    formatInput :: Int -> Int -> [String]+    formatInput row col = case advance (row - 1) rowsZipper of+        Zipper xs ys -> before ++ after where+            before = case span (\(_, _, b) -> b) xs of+                (_, [])     -> []+                (zs, z : _) -> map formatInputLine $ z : reverse zs++            after  = case ys of+                []        -> []+                (z : _zs) ->+                    [ formatInputLine z                             -- error line+                    , "      | " ++ replicate (col - 1) ' ' ++ "^"  -- pointer: ^+                    ]+                    -- do we need rows after?+                    -- ++ map formatInputLine (take 1 zs)           -- one row after++    formatInputLine :: (String, Int, Bool) -> String+    formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str++    -- hopefully we don't need to work with over 99999 lines .cabal files+    -- at that point small glitches in error messages are hopefully fine.+    leftPadShow :: Int -> String+    leftPadShow n = let s = show n in replicate (5 - length s) ' ' ++ s++data Zipper a = Zipper [a] [a]++listToZipper :: [a] -> Zipper a+listToZipper = Zipper []++advance :: Int -> Zipper a -> Zipper a+advance n z@(Zipper xs ys)+    | n <= 0 = z+    | otherwise = case ys of+        []      -> z+        (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys'
+ src/Distribution/Client/VCS.hs view
@@ -0,0 +1,642 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}+module Distribution.Client.VCS (+    -- * VCS driver type+    VCS,+    vcsRepoType,+    vcsProgram,+    -- ** Type re-exports+    RepoType,+    Program,+    ConfiguredProgram,++    -- * Validating 'SourceRepo's and configuring VCS drivers+    validatePDSourceRepo,+    validateSourceRepo,+    validateSourceRepos,+    SourceRepoProblem(..),+    configureVCS,+    configureVCSs,++    -- * Running the VCS driver+    cloneSourceRepo,+    syncSourceRepos,++    -- * The individual VCS drivers+    knownVCSs,+    vcsBzr,+    vcsDarcs,+    vcsGit,+    vcsHg,+    vcsSvn,+    vcsPijul,+  ) where++import Prelude ()+import Distribution.Client.Compat.Prelude++import Distribution.Types.SourceRepo+         ( RepoType(..), KnownRepoType (..) )+import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)+import Distribution.Client.RebuildMonad+         ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )+import Distribution.Verbosity as Verbosity+         ( normal )+import Distribution.Simple.Program+         ( Program(programFindVersion)+         , ConfiguredProgram(programVersion)+         , simpleProgram, findProgramVersion+         , ProgramInvocation(..), programInvocation, runProgramInvocation+         , emptyProgramDb, requireProgram )+import Distribution.Version+         ( mkVersion )+import qualified Distribution.PackageDescription as PD++import Control.Monad.Trans+         ( liftIO )+import qualified Data.Char as Char+import qualified Data.Map  as Map+import System.FilePath+         ( takeDirectory )+import System.Directory+         ( doesDirectoryExist )+++-- | A driver for a version control system, e.g. git, darcs etc.+--+data VCS program = VCS {+       -- | The type of repository this driver is for.+       vcsRepoType  :: RepoType,++       -- | The vcs program itself.+       -- This is used at type 'Program' and 'ConfiguredProgram'.+       vcsProgram   :: program,++       -- | The program invocation(s) to get\/clone a repository into a fresh+       -- local directory.+       vcsCloneRepo :: forall f. Verbosity+                    -> ConfiguredProgram+                    -> SourceRepositoryPackage f+                    -> FilePath   -- Source URI+                    -> FilePath   -- Destination directory+                    -> [ProgramInvocation],++       -- | The program invocation(s) to synchronise a whole set of /related/+       -- repositories with corresponding local directories. Also returns the+       -- files that the command depends on, for change monitoring.+       vcsSyncRepos :: forall f. Verbosity+                    -> ConfiguredProgram+                    -> [(SourceRepositoryPackage f, FilePath)]+                    -> IO [MonitorFilePath]+     }+++-- ------------------------------------------------------------+-- * Selecting repos and drivers+-- ------------------------------------------------------------++data SourceRepoProblem = SourceRepoRepoTypeUnspecified+                       | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType+                       | SourceRepoLocationUnspecified+  deriving Show++-- | Validates that the 'SourceRepo' specifies a location URI and a repository+-- type that is supported by a VCS driver.+--+-- | It also returns the 'VCS' driver we should use to work with it.+--+validateSourceRepo+    :: SourceRepositoryPackage f+    -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)+validateSourceRepo = \repo -> do+    let rtype = srpType repo+    vcs   <- Map.lookup rtype knownVCSs  ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype+    let uri = srpLocation repo+    return (repo, uri, rtype, vcs)+  where+    a ?! e = maybe (Left e) Right a++validatePDSourceRepo+    :: PD.SourceRepo+    -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)+validatePDSourceRepo repo = do+    rtype <- PD.repoType repo      ?! SourceRepoRepoTypeUnspecified+    uri   <- PD.repoLocation repo  ?! SourceRepoLocationUnspecified+    validateSourceRepo SourceRepositoryPackage+        { srpType     = rtype+        , srpLocation = uri+        , srpTag      = PD.repoTag repo+        , srpBranch   = PD.repoBranch repo+        , srpSubdir   = PD.repoSubdir repo+        , srpCommand  = mempty+        }+  where+    a ?! e = maybe (Left e) Right a++++-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return+-- things in a convenient form to pass to 'configureVCSs', or to report+-- problems.+--+validateSourceRepos :: [SourceRepositoryPackage f]+                    -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]+                              [(SourceRepositoryPackage f, String, RepoType, VCS Program)]+validateSourceRepos rs =+    case partitionEithers (map validateSourceRepo' rs) of+      (problems@(_:_), _) -> Left problems+      ([], vcss)          -> Right vcss+  where+    validateSourceRepo' r = either (Left . (,) r) Right+                                   (validateSourceRepo r)+++configureVCS :: Verbosity+             -> VCS Program+             -> IO (VCS ConfiguredProgram)+configureVCS verbosity vcs@VCS{vcsProgram = prog} =+    asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb+  where+    asVcsConfigured (prog', _) = vcs { vcsProgram = prog' }++configureVCSs :: Verbosity+              -> Map RepoType (VCS Program)+              -> IO (Map RepoType (VCS ConfiguredProgram))+configureVCSs verbosity = traverse (configureVCS verbosity)+++-- ------------------------------------------------------------+-- * Running the driver+-- ------------------------------------------------------------++-- | Clone a single source repo into a fresh directory, using a configured VCS.+--+-- This is for making a new copy, not synchronising an existing copy. It will+-- fail if the destination directory already exists.+--+-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.+--++cloneSourceRepo+    :: Verbosity+    -> VCS ConfiguredProgram+    -> SourceRepositoryPackage f+    -> [Char]+    -> IO ()+cloneSourceRepo verbosity vcs+                repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =+    traverse_ (runProgramInvocation verbosity) invocations+  where+    invocations = vcsCloneRepo vcs verbosity+                               (vcsProgram vcs) repo+                               srcuri destdir+++-- | Syncronise a set of 'SourceRepo's referring to the same repository with+-- corresponding local directories. The local directories may or may not+-- already exist.+--+-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos',+-- or used across a series of invocations with any local directory must refer+-- to the /same/ repository. That means it must be the same location but they+-- can differ in the branch, or tag or subdir.+--+-- The reason to allow multiple related 'SourceRepo's is to allow for the+-- network or storage to be shared between different checkouts of the repo.+-- For example if a single repo contains multiple packages in different subdirs+-- and in some project it may make sense to use a different state of the repo+-- for one subdir compared to another.+--+syncSourceRepos :: Verbosity+                -> VCS ConfiguredProgram+                -> [(SourceRepositoryPackage f, FilePath)]+                -> Rebuild ()+syncSourceRepos verbosity vcs repos = do+    files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos+    monitorFiles files+++-- ------------------------------------------------------------+-- * The various VCS drivers+-- ------------------------------------------------------------++-- | The set of all supported VCS drivers, organised by 'RepoType'.+--+knownVCSs :: Map RepoType (VCS Program)+knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]+  where+    vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]+++-- | VCS driver for Bazaar.+--+vcsBzr :: VCS Program+vcsBzr =+    VCS {+      vcsRepoType = KnownRepoType Bazaar,+      vcsProgram  = bzrProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo verbosity prog repo srcuri destdir =+        [ programInvocation prog+            ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ]+      where+        -- The @get@ command was deprecated in version 2.4 in favour of+        -- the alias @branch@+        branchCmd | programVersion prog >= Just (mkVersion [2,4])+                              = "branch"+                  | otherwise = "get"++        tagArgs = case srpTag repo of+          Nothing  -> []+          Just tag -> ["-r", "tag:" ++ tag]+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]++    vcsSyncRepos :: Verbosity -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]+    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"++bzrProgram :: Program+bzrProgram = (simpleProgram "bzr") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- "Bazaar (bzr) 2.6.0\n  ... lots of extra stuff"+        (_:_:ver:_) -> ver+        _ -> ""+  }+++-- | VCS driver for Darcs.+--+vcsDarcs :: VCS Program+vcsDarcs =+    VCS {+      vcsRepoType = KnownRepoType Darcs,+      vcsProgram  = darcsProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo verbosity prog repo srcuri destdir =+        [ programInvocation prog cloneArgs ]+      where+        cloneArgs  = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg+        -- At some point the @clone@ command was introduced as an alias for+        -- @get@, and @clone@ seems to be the recommended one now.+        cloneCmd   | programVersion prog >= Just (mkVersion [2,8])+                               = "clone"+                   | otherwise = "get"+        tagArgs    = case srpTag repo of+          Nothing  -> []+          Just tag -> ["-t", tag]+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]++    vcsSyncRepos :: Verbosity -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]+    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs"++darcsProgram :: Program+darcsProgram = (simpleProgram "darcs") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- "2.8.5 (release)"+        (ver:_) -> ver+        _ -> ""+  }+++-- | VCS driver for Git.+--+vcsGit :: VCS Program+vcsGit =+    VCS {+      vcsRepoType = KnownRepoType Git,+      vcsProgram  = gitProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo verbosity prog repo srcuri destdir =+        [ programInvocation prog cloneArgs ]+        -- And if there's a tag, we have to do that in a second step:+     ++ [ (programInvocation prog (checkoutArgs tag)) {+            progInvokeCwd = Just destdir+          }+        | tag <- maybeToList (srpTag repo) ]+      where+        cloneArgs  = ["clone", srcuri, destdir]+                     ++ branchArgs ++ verboseArg+        branchArgs = case srpBranch repo of+          Just b  -> ["--branch", b]+          Nothing -> []+        checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]++    vcsSyncRepos :: Verbosity+                 -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)]+                 -> IO [MonitorFilePath]+    vcsSyncRepos _ _ [] = return []+    vcsSyncRepos verbosity gitProg+                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do++      vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing+      sequence_+        [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)+        | (repo, localDir) <- secondaryRepos ]+      return [ monitorDirectoryExistence dir+             | dir <- (primaryLocalDir : map snd secondaryRepos) ]++    vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do+        exists <- doesDirectoryExist localDir+        if exists+          then git localDir                 ["fetch"]+          else git (takeDirectory localDir) cloneArgs+        git localDir checkoutArgs+      where+        git :: FilePath -> [String] -> IO ()+        git cwd args = runProgramInvocation verbosity $+                         (programInvocation gitProg args) {+                           progInvokeCwd = Just cwd+                         }++        cloneArgs      = ["clone", "--no-checkout", loc, localDir]+                      ++ case peer of+                           Nothing           -> []+                           Just peerLocalDir -> ["--reference", peerLocalDir]+                      ++ verboseArg+                         where loc = srpLocation+        checkoutArgs   = "checkout" : verboseArg ++ ["--detach", "--force"+                         , checkoutTarget, "--" ]+        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)+        verboseArg     = [ "--quiet" | verbosity < Verbosity.normal ]++gitProgram :: Program+gitProgram = (simpleProgram "git") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- "git version 2.5.5"+        (_:_:ver:_) | all isTypical ver -> ver++        -- or annoyingly "git version 2.17.1.windows.2" yes, really+        (_:_:ver:_) -> intercalate "."+                     . takeWhile (all isNum)+                     . split+                     $ ver+        _ -> ""+  }+  where+    isNum     c = c >= '0' && c <= '9'+    isTypical c = isNum c || c == '.'+    split    cs = case break (=='.') cs of+                    (chunk,[])     -> chunk : []+                    (chunk,_:rest) -> chunk : split rest++-- | VCS driver for Mercurial.+--+vcsHg :: VCS Program+vcsHg =+    VCS {+      vcsRepoType = KnownRepoType Mercurial,+      vcsProgram  = hgProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo verbosity prog repo srcuri destdir =+        [ programInvocation prog cloneArgs ]+      where+        cloneArgs  = ["clone", srcuri, destdir]+                     ++ branchArgs ++ tagArgs ++ verboseArg+        branchArgs = case srpBranch repo of+          Just b  -> ["--branch", b]+          Nothing -> []+        tagArgs = case srpTag repo of+          Just t  -> ["--rev", t]+          Nothing -> []+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]++    vcsSyncRepos :: Verbosity+                 -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)]+                 -> IO [MonitorFilePath]+    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"++hgProgram :: Program+hgProgram = (simpleProgram "hg") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- Mercurial Distributed SCM (version 3.5.2)\n ... long message+        (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver+        _ -> ""+  }+++-- | VCS driver for Subversion.+--+vcsSvn :: VCS Program+vcsSvn =+    VCS {+      vcsRepoType = KnownRepoType SVN,+      vcsProgram  = svnProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo verbosity prog _repo srcuri destdir =+        [ programInvocation prog checkoutArgs ]+      where+        checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg+        verboseArg   = [ "--quiet" | verbosity < Verbosity.normal ]+        --TODO: branch or tag?++    vcsSyncRepos :: Verbosity+                 -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)]+                 -> IO [MonitorFilePath]+    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"++svnProgram :: Program+svnProgram = (simpleProgram "svn") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- svn, version 1.9.4 (r1740329)\n ... long message+        (_:_:ver:_) -> ver+        _ -> ""+  }+++-- | VCS driver for Pijul.+-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>+--+-- 2020-04-09 Oleg:+--+--    As far as I understand pijul, there are branches and "tags" in pijul,+--    but there aren't a "commit hash" identifying an arbitrary state.+--+--    One can create `a pijul tag`, which will make a patch hash,+--    which depends on everything currently in the repository.+--    I guess if you try to apply that patch, you'll be forced to apply+--    all the dependencies too. In other words, there are no named tags.+--+--    It's not clear to me whether there is an option to+--    "apply this patch *and* all of its dependencies".+--    And relatedly, whether how to make sure that there are no other+--    patches applied.+--+--    With branches it's easier, as you can `pull` and `checkout` them,+--    and they seem to be similar enough. Yet, pijul documentations says+--+--    > Note that the purpose of branches in Pijul is quite different from Git,+--      since Git's "feature branches" can usually be implemented by just+--      patches.+--+--    I guess it means that indeed instead of creating a branch and making PR+--    in "GitHub" workflow, you'd just create a patch and offer it.+--    You can do that with `git` too. Push (a branch with) commit to remote+--    and ask other to cherry-pick that commit. Yet, in git identity of commit+--    changes when it applied to other trees, where patches in pijul have+--    will continue to have the same hash.+--+--    Unfortunately pijul doesn't talk about conflict resolution.+--    It seems that you get something like:+--+--        % pijul status+--        On branch merge+--+--        Unresolved conflicts:+--          (fix conflicts and record the resolution with "pijul record ...")+--+--                foo+--+--        % cat foo+--        first line+--        >> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>+--        branch BBB+--        ================================+--        branch AAA+--        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<+--        last line+--+--    And then the `pijul dependencies` would draw you a graph like+--+--+--                    ----->  foo on branch B ----->+--    resolve confict                                  Initial patch+--                    ----->  foo on branch A ----->+--+--    Which is seems reasonable.+--+--    So currently, pijul support is very experimental, and most likely+--    won't work, even the basics are in place. Tests are also written+--    but disabled, as the branching model differs from `git` one,+--    for which tests are written.+--+vcsPijul :: VCS Program+vcsPijul =+    VCS {+      vcsRepoType = KnownRepoType Pijul,+      vcsProgram  = pijulProgram,+      vcsCloneRepo,+      vcsSyncRepos+    }+  where+    vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag+                 -> ConfiguredProgram+                 -> SourceRepositoryPackage f+                 -> FilePath+                 -> FilePath+                 -> [ProgramInvocation]+    vcsCloneRepo _verbosity prog repo srcuri destdir =+        [ programInvocation prog cloneArgs ]+        -- And if there's a tag, we have to do that in a second step:+     ++ [ (programInvocation prog (checkoutArgs tag)) {+            progInvokeCwd = Just destdir+          }+        | tag <- maybeToList (srpTag repo) ]+      where+        cloneArgs  = ["clone", srcuri, destdir]+                     ++ branchArgs+        branchArgs = case srpBranch repo of+          Just b  -> ["--from-branch", b]+          Nothing -> []+        checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either++    vcsSyncRepos :: Verbosity+                 -> ConfiguredProgram+                 -> [(SourceRepositoryPackage f, FilePath)]+                 -> IO [MonitorFilePath]+    vcsSyncRepos _ _ [] = return []+    vcsSyncRepos verbosity pijulProg+                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do++      vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing+      sequence_+        [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)+        | (repo, localDir) <- secondaryRepos ]+      return [ monitorDirectoryExistence dir+             | dir <- (primaryLocalDir : map snd secondaryRepos) ]++    vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do+        exists <- doesDirectoryExist localDir+        if exists+        then pijul localDir                 ["pull"] -- TODO: this probably doesn't work.+        else pijul (takeDirectory localDir) cloneArgs+        pijul localDir checkoutArgs+      where+        pijul :: FilePath -> [String] -> IO ()+        pijul cwd args = runProgramInvocation verbosity $+                         (programInvocation pijulProg args) {+                           progInvokeCwd = Just cwd+                         }++        cloneArgs      = ["clone", loc, localDir]+                      ++ case peer of+                           Nothing           -> []+                           Just peerLocalDir -> [peerLocalDir]+                         where loc = srpLocation+        checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]+        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.++pijulProgram :: Program+pijulProgram = (simpleProgram "pijul") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      case words str of+        -- "pijul 0.12.2+        (_:ver:_) | all isTypical ver -> ver+        _ -> ""+  }+  where+    isNum     c = c >= '0' && c <= '9'+    isTypical c = isNum c || c == '.'
+ src/Distribution/Client/Win32SelfUpgrade.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Win32SelfUpgrade+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Support for self-upgrading executables on Windows platforms.+-----------------------------------------------------------------------------+module Distribution.Client.Win32SelfUpgrade (+-- * Explanation+--+-- | Windows inherited a design choice from DOS that while initially innocuous+-- has rather unfortunate consequences. It maintains the invariant that every+-- open file has a corresponding name on disk. One positive consequence of this+-- is that an executable can always find its own executable file. The downside+-- is that a program cannot be deleted or upgraded while it is running without+-- hideous workarounds. This module implements one such hideous workaround.+--+-- The basic idea is:+--+-- * 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+-- * Wait for the new process to start+-- * Close the new exe file+-- * Exit old process+--+-- Then in the new process:+--+-- * Inform the old process that we've started+-- * Wait for the old process to die+-- * Delete the old exe file+-- * Exit new process+--++    possibleSelfUpgrade,+    deleteOldExeFile,+  ) where++import Distribution.Client.Compat.Prelude hiding (log)+import Prelude ()++#ifdef mingw32_HOST_OS++import qualified System.Win32 as Win32+import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)+import Foreign.Ptr (Ptr, nullPtr)+import System.Process (runProcess)+import System.Directory (canonicalizePath)+import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)++import Distribution.Verbosity as Verbosity (showForCabal)+import Distribution.Simple.Utils (debug, info)+++-- | If one of the given files is our own exe file then we arrange things such+-- 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.+--+possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade verbosity newPaths action = do+  dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE++  newPaths' <- traverse canonicalizePath newPaths+  let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'++  if not doingSelfUpgrade+    then action+    else do+      info verbosity $ "cabal-install does the replace-own-exe-file dance..."+      tmpPath <- moveOurExeOutOfTheWay verbosity+      result <- action+      scheduleOurDemise verbosity dstPath tmpPath+        (\pid path -> ["win32selfupgrade", pid, path+                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])+      return result++-- | The name of a Win32 Event object that we use to synchronise between the+-- 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+-- re-used).+--+syncEventName :: String+syncEventName = "Local\\cabal-install-upgrade"++-- | The first part of allowing our exe file to be replaced is to move the+-- existing exe file out of the way. Although we cannot delete our exe file+-- while we're still running, fortunately we can rename it, at least within+-- the same directory.+--+moveOurExeOutOfTheWay :: Verbosity -> IO FilePath+moveOurExeOutOfTheWay verbosity = do+  ourPID  <-       getCurrentProcessId+  dstPath <- Win32.getModuleFileName Win32.nullHANDLE++  let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)++  debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath+  Win32.moveFile dstPath tmpPath+  return tmpPath++-- | Assuming we've now installed the new exe file in the right place, we+-- launch it and ask it to delete our exe file when we eventually terminate.+--+scheduleOurDemise :: Verbosity -> FilePath -> FilePath+                  -> (String -> FilePath -> [String]) -> IO ()+scheduleOurDemise verbosity dstPath tmpPath mkArgs = do+  ourPID <- getCurrentProcessId+  event  <- createEvent syncEventName++  let args = mkArgs (show ourPID) tmpPath+  log $ "launching child " ++ unwords (dstPath : map show args)+  _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing++  log $ "waiting for the child to start up"+  waitForSingleObject event (10*1000) -- wait at most 10 sec+  log $ "child started ok"++  where+    log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)++-- | 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 renamed itself to.+--+deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile verbosity oldPID tmpPath = do+  log $ "process started. Will delete exe file of process "+     ++ show oldPID ++ " at path " ++ tmpPath++  log $ "getting handle of parent process " ++ show oldPID+  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)++  log $ "synchronising with parent"+  event <- openEvent syncEventName+  setEvent event++  log $ "waiting for parent process to terminate"+  waitForSingleObject oldPHANDLE Win32.iNFINITE+  log $ "parent process terminated"++  log $ "deleting parent's old .exe file"+  Win32.deleteFile tmpPath++  where+    log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)++------------------------+-- Win32 foreign imports+--++-- A bunch of functions sadly not provided by the Win32 package.++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "windows.h GetCurrentProcessId"+  getCurrentProcessId :: IO DWORD++foreign import CALLCONV unsafe "windows.h WaitForSingleObject"+  waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD++waitForSingleObject :: HANDLE -> DWORD -> IO ()+waitForSingleObject handle timeout =+  Win32.failIf_ bad "WaitForSingleObject" $+    waitForSingleObject_ handle timeout+  where+    bad result   = not (result == 0 || result == wAIT_TIMEOUT)+    wAIT_TIMEOUT = 0x00000102++foreign import CALLCONV unsafe "windows.h CreateEventW"+  createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE++createEvent :: String -> IO HANDLE+createEvent name = do+  Win32.failIfNull "CreateEvent" $+    Win32.withTString name $+      createEvent_ nullPtr False False++foreign import CALLCONV unsafe "windows.h OpenEventW"+  openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++openEvent :: String -> IO HANDLE+openEvent name = do+  Win32.failIfNull "OpenEvent" $+    Win32.withTString name $+      openEvent_ eVENT_MODIFY_STATE False+  where+    eVENT_MODIFY_STATE :: DWORD+    eVENT_MODIFY_STATE = 0x0002++foreign import CALLCONV unsafe "windows.h SetEvent"+  setEvent_ :: HANDLE -> IO BOOL++setEvent :: HANDLE -> IO ()+setEvent handle =+  Win32.failIfFalse_ "SetEvent" $+    setEvent_ handle++#else++import Distribution.Simple.Utils (die')++possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade _ _ action = action++deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32"++#endif
+ src/Distribution/Client/World.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveGeneric #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.World+-- Copyright   :  (c) Peter Robinson 2009+-- License     :  BSD-like+--+-- Maintainer  :  thaldyron@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Interface to the world-file that contains a list of explicitly+-- requested packages. Meant to be imported qualified.+--+-- A world file entry stores the package-name, package-version, and+-- user flags.+-- For example, the entry generated by+-- # cabal install stm-io-hooks --flags="-debug"+-- looks like this:+-- # stm-io-hooks -any --flags="-debug"+-- To rebuild/upgrade the packages in world (e.g. when updating the compiler)+-- use+-- # cabal install world+--+-----------------------------------------------------------------------------+module Distribution.Client.World (+    WorldPkgInfo(..),+    insert,+    delete,+    getContents,+  ) where++import Prelude (sequence)+import Distribution.Client.Compat.Prelude hiding (getContents)++import Distribution.Types.Dependency+import Distribution.Types.Flag+         ( FlagAssignment, unFlagAssignment+         , unFlagName, parsecFlagAssignmentNonEmpty )+import Distribution.Simple.Utils+         ( die', info, chattyTry, writeFileAtomic )+import qualified Distribution.Compat.CharParsing as P+import qualified Text.PrettyPrint as Disp++import Data.List+         ( unionBy, deleteFirstsBy )+import System.IO.Error+         ( isDoesNotExistError )+import qualified Data.ByteString.Lazy.Char8 as B+++data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment+  deriving (Show,Eq, Generic)++-- | Adds packages to the world file; creates the file if it doesn't+-- exist yet. Version constraints and flag assignments for a package are+-- updated if already present. IO errors are non-fatal.+insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+insert = modifyWorld $ unionBy equalUDep++-- | Removes packages from the world file.+-- Note: Currently unused as there is no mechanism in Cabal (yet) to+-- handle uninstalls. IO errors are non-fatal.+delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+delete = modifyWorld $ flip (deleteFirstsBy equalUDep)++-- | WorldPkgInfo values are considered equal if they refer to+-- the same package, i.e., we don't care about differing versions or flags.+equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool+equalUDep (WorldPkgInfo (Dependency pkg1 _ _) _)+          (WorldPkgInfo (Dependency pkg2 _ _) _) = pkg1 == pkg2++-- | Modifies the world file by applying an update-function ('unionBy'+-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of+-- packages. IO errors are considered non-fatal.+modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]+                -> [WorldPkgInfo])+                        -- ^ Function that defines how+                        -- the list of user packages are merged with+                        -- existing world packages.+            -> Verbosity+            -> FilePath               -- ^ Location of the world file+            -> [WorldPkgInfo] -- ^ list of user supplied packages+            -> IO ()+modifyWorld _ _         _     []   = return ()+modifyWorld f verbosity world pkgs =+  chattyTry "Error while updating world-file. " $ do+    pkgsOldWorld <- getContents verbosity world+    -- Filter out packages that are not in the world file:+    let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld+    -- 'Dependency' is not an Ord instance, so we need to check for+    -- equivalence the awkward way:+    if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&+            all (`elem` pkgsNewWorld) pkgsOldWorld)+      then do+        info verbosity "Updating world file..."+        writeFileAtomic world . B.pack $ unlines+            [ (prettyShow pkg) | pkg <- pkgsNewWorld]+      else+        info verbosity "World file is already up to date."+++-- | Returns the content of the world file as a list+getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo]+getContents verbosity world = do+  content <- safelyReadFile world+  let result = map simpleParsec (lines $ B.unpack content)+  case sequence result of+    Nothing -> die' verbosity "Could not parse world file."+    Just xs -> return xs+  where+  safelyReadFile :: FilePath -> IO B.ByteString+  safelyReadFile file = B.readFile file `catchIO` handler+    where+      handler e | isDoesNotExistError e = return B.empty+                | otherwise             = ioError e+++instance Pretty WorldPkgInfo where+  pretty (WorldPkgInfo dep flags) = pretty dep Disp.<+> dispFlags (unFlagAssignment flags)+    where+      dispFlags [] = Disp.empty+      dispFlags fs = Disp.text "--flags="+                  <<>> Disp.doubleQuotes (flagAssToDoc fs)+      flagAssToDoc = foldr (\(fname,val) flagAssDoc ->+                             (if not val then Disp.char '-'+                                         else Disp.char '+')+                             <<>> Disp.text (unFlagName fname)+                             Disp.<+> flagAssDoc)+                           Disp.empty++instance Parsec WorldPkgInfo where+  parsec = do+      dep <- parsec+      P.spaces+      flagAss <- P.option mempty parseFlagAssignment+      return $ WorldPkgInfo dep flagAss+    where+      parseFlagAssignment :: CabalParsing m => m FlagAssignment+      parseFlagAssignment = do+          _ <- P.string "--flags="+          inDoubleQuotes parsecFlagAssignmentNonEmpty+        where+          inDoubleQuotes = P.between (P.char '"') (P.char '"')
+ src/Distribution/Deprecated/ParseUtils.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Deprecated.ParseUtils+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD3+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.+--+-- The @.cabal@ file format is not trivial, especially with the introduction+-- of configurations and the section syntax that goes with that. This module+-- has a bunch of parsing functions that is used by the @.cabal@ parser and a+-- couple others. It has the parsing framework code and also little parsers for+-- many of the formats we get in various @.cabal@ file fields, like module+-- names, comma separated lists etc.++-- This module is meant to be local-only to Distribution...++{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE Rank2Types #-}+module Distribution.Deprecated.ParseUtils (+        LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,+        runP, runE, ParseResult(..), parseFail, showPWarning,+        Field(..), lineNo,+        FieldDescr(..), readFields,+        parseHaskellString, parseTokenQ,+        parseOptCommaList,+        showFilePath, showToken, showFreeText,+        field, simpleField, listField, listFieldWithSep, spaceListField,+        newLineListField,+        liftField,+        readPToMaybe,++        fieldParsec, simpleFieldParsec,+        listFieldParsec,+        commaListFieldParsec,+        commaNewLineListFieldParsec,++        UnrecFieldParser,+  ) where++import Distribution.Client.Compat.Prelude hiding (get)+import Prelude ()++import Distribution.Deprecated.ReadP as ReadP hiding (get)++import Distribution.Pretty+import Distribution.ReadE+import Distribution.Utils.Generic++import System.FilePath  (normalise)+import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep)+import qualified Text.Read as Read++import qualified Control.Monad.Fail as Fail+import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingOptCommaList)++import qualified Data.ByteString as BS+import qualified Distribution.Fields as Fields+import qualified Distribution.Fields.Field as Fields+import qualified Distribution.Parsec as Parsec+import qualified Distribution.Fields.LexerMonad as Fields+import qualified Text.Parsec.Error as PE+import qualified Text.Parsec.Pos as PP++-- -----------------------------------------------------------------------------++type LineNo    = Int++data PError = AmbiguousParse String LineNo+            | NoParse String LineNo+            | TabsError LineNo+            | FromString String (Maybe LineNo)+        deriving (Eq, Show)++data PWarning = PWarning String+              | UTFWarning LineNo String+        deriving (Eq, Show)++showPWarning :: FilePath -> PWarning -> String+showPWarning fpath (PWarning msg) =+  normalise fpath ++ ": " ++ msg+showPWarning fpath (UTFWarning line fname) =+  normalise fpath ++ ":" ++ show line+        ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."++data ParseResult a = ParseFailed PError | ParseOk [PWarning] a+        deriving Show++instance Functor ParseResult where+        fmap _ (ParseFailed err) = ParseFailed err+        fmap f (ParseOk ws x) = ParseOk ws $ f x++instance Applicative ParseResult where+        pure = ParseOk []+        (<*>) = ap+++instance Monad ParseResult where+        return = pure+        ParseFailed err >>= _ = ParseFailed err+        ParseOk ws x >>= f = case f x of+                               ParseFailed err -> ParseFailed err+                               ParseOk ws' x' -> ParseOk (ws'++ws) x'++#if !(MIN_VERSION_base(4,9,0))+        fail = parseResultFail+#elif !(MIN_VERSION_base(4,13,0))+        fail = Fail.fail+#endif++instance Fail.MonadFail ParseResult where+        fail = parseResultFail++parseResultFail :: String -> ParseResult a+parseResultFail s = parseFail (FromString s Nothing)++parseFail :: PError -> ParseResult a+parseFail = ParseFailed++runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a+runP line fieldname p s =+  case [ x | (x,"") <- results ] of+    [a] -> ParseOk (utf8Warnings line fieldname s) a+    --TODO: what is this double parse thing all about?+    --      Can't we just do the all isSpace test the first time?+    []  -> case [ x | (x,ys) <- results, all isSpace ys ] of+             [a] -> ParseOk (utf8Warnings line fieldname s) a+             []  -> ParseFailed (NoParse fieldname line)+             _   -> ParseFailed (AmbiguousParse fieldname line)+    _   -> ParseFailed (AmbiguousParse fieldname line)+  where results = readP_to_S p s++runE :: LineNo -> String -> ReadE a -> String -> ParseResult a+runE line fieldname p s =+    case runReadE p s of+      Right a -> ParseOk (utf8Warnings line fieldname s) a+      Left  e -> syntaxError line $+        "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s++utf8Warnings :: LineNo -> String -> String -> [PWarning]+utf8Warnings line fieldname s =+  take 1 [ UTFWarning n fieldname+         | (n,l) <- zip [line..] (lines s)+         , '\xfffd' `elem` l ]++locatedErrorMsg :: PError -> (Maybe LineNo, String)+locatedErrorMsg (AmbiguousParse f n) = (Just n,+                                        "Ambiguous parse in field '"++f++"'.")+locatedErrorMsg (NoParse f n)        = (Just n,+                                        "Parse of field '"++f++"' failed.")+locatedErrorMsg (TabsError n)        = (Just n, "Tab used as indentation.")+locatedErrorMsg (FromString s n)     = (n, s)++syntaxError :: LineNo -> String -> ParseResult a+syntaxError n s = ParseFailed $ FromString s (Just n)+++warning :: String -> ParseResult ()+warning s = ParseOk [PWarning s] ()++-- | Field descriptor.  The parameter @a@ parameterizes over where the field's+--   value is stored in.+data FieldDescr a+  = FieldDescr+      { fieldName     :: String+      , fieldGet      :: a -> Doc+      , fieldSet      :: LineNo -> String -> a -> ParseResult a+        -- ^ @fieldSet n str x@ Parses the field value from the given input+        -- string @str@ and stores the result in @x@ if the parse was+        -- successful.  Otherwise, reports an error on line number @n@.+      }++field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a+field name showF readF =+  FieldDescr name showF (\line val _st -> runP line name readF val)++fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a+fieldParsec name showF readF =+  FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of+    Left err -> ParseFailed (FromString err (Just line))+    Right x  -> ParseOk [] x++-- Lift a field descriptor storing into an 'a' to a field descriptor storing+-- into a 'b'.+liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b+liftField get set (FieldDescr name showF parseF)+ = FieldDescr name (showF . get)+        (\line str b -> do+            a <- parseF line str (get b)+            return (set a b))++-- Parser combinator for simple fields.  Takes a field name, a pretty printer,+-- a parser function, an accessor, and a setter, returns a FieldDescr over the+-- compoid structure.+simpleField :: String -> (a -> Doc) -> ReadP a a+            -> (b -> a) -> (a -> b -> b) -> FieldDescr b+simpleField name showF readF get set+  = liftField get set $ field name showF readF++simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a+            -> (b -> a) -> (a -> b -> b) -> FieldDescr b+simpleFieldParsec name showF readF get set+  = liftField get set $ fieldParsec name showF readF++commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a+                      -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaListFieldWithSepParsec separator name showF readF get set =+   liftField get set' $+     fieldParsec name showF' (parsecLeadingCommaList readF)+   where+     set' xs b = set (get b ++ xs) b+     showF'    = separator . punctuate comma . map showF++commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaListFieldParsec = commaListFieldWithSepParsec fsep++commaNewLineListFieldParsec+    :: String -> (a -> Doc) ->  ParsecParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaNewLineListFieldParsec = commaListFieldWithSepParsec sep++spaceListField :: String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+spaceListField name showF readF get set =+  liftField get set' $+    field name showF' (parseSpaceList readF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = fsep . map showF++-- this is a different definition from listField, like+-- commaNewLineListField it pretty prints on multiple lines+newLineListField :: String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+newLineListField = listFieldWithSep sep++listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listFieldWithSep separator name showF readF get set =+  liftField get set' $+    field name showF' (parseOptCommaList readF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF++listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listFieldWithSepParsec separator name showF readF get set =+  liftField get set' $+    fieldParsec name showF' (parsecLeadingOptCommaList readF)+  where+    set' xs b = set (get b ++ xs) b+    showF'    = separator . map showF++listField :: String -> (a -> Doc) -> ReadP [a] a+          -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listField = listFieldWithSep fsep++listFieldParsec+    :: String -> (a -> Doc) -> ParsecParser a+    -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listFieldParsec = listFieldWithSepParsec fsep++-- | The type of a function which, given a name-value pair of an+--   unrecognized field, and the current structure being built,+--   decides whether to incorporate the unrecognized field+--   (by returning  Just x, where x is a possibly modified version+--   of the structure being built), or not (by returning Nothing).+type UnrecFieldParser a = (String,String) -> a -> Maybe a++------------------------------------------------------------------------------++-- The data type for our three syntactic categories+data Field+    = F LineNo String String+      -- ^ A regular @<property>: <value>@ field+    | Section LineNo String String [Field]+      -- ^ A section with a name and possible parameter.  The syntactic+      -- structure is:+      --+      -- @+      --   <sectionname> <arg> {+      --     <field>*+      --   }+      -- @+      deriving (Show+               ,Eq)   -- for testing++lineNo :: Field -> LineNo+lineNo (F n _ _) = n+lineNo (Section n _ _ _) = n++readFields :: BS.ByteString -> ParseResult [Field]+readFields input = case Fields.readFields' input of+    Right (fs, ws) -> ParseOk+        [ PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws ]+        (legacyFields fs)+    Left perr      -> ParseFailed $ NoParse+        (PE.showErrorMessages+            "or" "unknown parse error" "expecting" "unexpected" "end of file"+            (PE.errorMessages perr))+        (PP.sourceLine pos)+      where+        pos = PE.errorPos perr++legacyFields :: [Fields.Field Parsec.Position] -> [Field]+legacyFields = map legacyField++legacyField :: Fields.Field Parsec.Position -> Field+legacyField (Fields.Field (Fields.Name pos name) fls) =+    F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls)+legacyField (Fields.Section (Fields.Name pos name) args fs) =+    Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs)++posToLineNo :: Parsec.Position -> LineNo+posToLineNo (Parsec.Position row _) = row++------------------------------------------------------------------------------++-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a+-- because the "compat" version of ReadP isn't quite powerful enough.  In+-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a+-- Hence the trick above to make 'lic' polymorphic.++-- Different than the naive version. it turns out Read instance for String accepts+-- the ['a', 'b'] syntax, which we do not want. In particular it messes+-- up any token starting with [].+parseHaskellString :: ReadP r String+parseHaskellString =+  readS_to_P $+    Read.readPrec_to_S (do Read.String s <- Read.lexP; return s) 0++parseTokenQ :: ReadP r String+parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')++parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas+               -> ReadP r [a]+parseSpaceList p = sepBy p skipSpaces++-- This version avoid parse ambiguity for list element parsers+-- that have multiple valid parses of prefixes.+parseOptCommaList :: ReadP r a -> ReadP r [a]+parseOptCommaList p = sepBy p localSep+  where+    -- The separator must not be empty or it introduces ambiguity+    localSep = (skipSpaces >> char ',' >> skipSpaces)+      +++ (satisfy isSpace >> skipSpaces)++readPToMaybe :: ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str+                                     , all isSpace s ]
+ src/Distribution/Deprecated/ReadP.hs view
@@ -0,0 +1,449 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+-----------------------------------------------------------------------------+-- |+--+-- Module      :  Distribution.Deprecated.ReadP+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- This is a library of parser combinators, originally written by Koen Claessen.+-- It parses all alternatives in parallel, so it never keeps hold of+-- the beginning of the input string, a common source of space leaks with+-- other parsers.  The '(+++)' choice combinator is genuinely commutative;+-- it makes no difference which branch is \"shorter\".+--+-- See also Koen's paper /Parallel Parsing Processes/+-- (<http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).+--+-- This version of ReadP has been locally hacked to make it H98, by+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>+--+-- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by+-- Mark Lentczner <mailto:mark@glyphic.com>+-----------------------------------------------------------------------------++module Distribution.Deprecated.ReadP+  (+  -- * The 'ReadP' type+  ReadP,      -- :: * -> *; instance Functor, Monad, MonadPlus++  -- * Primitive operations+  get,        -- :: ReadP Char+  look,       -- :: ReadP String+  (+++),      -- :: ReadP a -> ReadP a -> ReadP a+  (<++),      -- :: ReadP a -> ReadP a -> ReadP a+  gather,     -- :: ReadP a -> ReadP (String, a)++  -- * Other operations+  pfail,      -- :: ReadP a+  eof,        -- :: ReadP ()+  satisfy,    -- :: (Char -> Bool) -> ReadP Char+  char,       -- :: Char -> ReadP Char+  string,     -- :: String -> ReadP String+  munch,      -- :: (Char -> Bool) -> ReadP String+  munch1,     -- :: (Char -> Bool) -> ReadP String+  skipSpaces, -- :: ReadP ()+  skipSpaces1,-- :: ReadP ()+  choice,     -- :: [ReadP a] -> ReadP a+  count,      -- :: Int -> ReadP a -> ReadP [a]+  between,    -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a+  option,     -- :: a -> ReadP a -> ReadP a+  optional,   -- :: ReadP a -> ReadP ()+  many,       -- :: ReadP a -> ReadP [a]+  many1,      -- :: ReadP a -> ReadP [a]+  skipMany,   -- :: ReadP a -> ReadP ()+  skipMany1,  -- :: ReadP a -> ReadP ()+  sepBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  sepBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy,      -- :: ReadP a -> ReadP sep -> ReadP [a]+  endBy1,     -- :: ReadP a -> ReadP sep -> ReadP [a]+  chainr,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl,     -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a+  chainl1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  chainr1,    -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a+  manyTill,   -- :: ReadP a -> ReadP end -> ReadP [a]++  -- * Running a parser+  ReadS,      -- :: *; = String -> [(a,String)]+  readP_to_S, -- :: ReadP a -> ReadS a+  readS_to_P, -- :: ReadS a -> ReadP a+  readP_to_E,++  -- ** Internal+  Parser,+  )+ where++import Prelude ()+import Distribution.Client.Compat.Prelude hiding (many, get)++import Control.Monad( replicateM, (>=>) )++import qualified Control.Monad.Fail as Fail++import Distribution.ReadE (ReadE (..))++infixr 5 +++, <++++-- ---------------------------------------------------------------------------+-- The P type+-- is representation type -- should be kept abstract++data P s a+  = Get (s -> P s a)+  | Look ([s] -> P s a)+  | Fail+  | Result a (P s a)+  | Final [(a,[s])] -- invariant: list is non-empty!++-- Monad, MonadPlus++instance Functor (P s) where+  fmap = liftM++instance Applicative (P s) where+  pure x = Result x Fail+  (<*>) = ap++instance Monad (P s) where+  return = pure++  (Get f)      >>= k = Get (f >=> k)+  (Look f)     >>= k = Look (f >=> k)+  Fail         >>= _ = Fail+  (Result x p) >>= k = k x `mplus` (p >>= k)+  (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]++#if !(MIN_VERSION_base(4,9,0))+  fail _ = Fail+#elif !(MIN_VERSION_base(4,13,0))+  fail = Fail.fail+#endif++instance Fail.MonadFail (P s) where+  fail _ = Fail++instance Alternative (P s) where+      empty = mzero+      (<|>) = mplus++instance MonadPlus (P s) where+  mzero = Fail++  -- most common case: two gets are combined+  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)++  -- results are delivered as soon as possible+  Result x p `mplus` q          = Result x (p `mplus` q)+  p          `mplus` Result x q = Result x (p `mplus` q)++  -- fail disappears+  Fail       `mplus` p          = p+  p          `mplus` Fail       = p++  -- two finals are combined+  -- final + look becomes one look and one final (=optimization)+  -- final + sthg else becomes one look and one final+  Final r    `mplus` Final t    = Final (r ++ t)+  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))+  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))+  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))+  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))++  -- two looks are combined (=optimization)+  -- look + sthg else floats upwards+  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)+  Look f     `mplus` p          = Look (\s -> f s `mplus` p)+  p          `mplus` Look f     = Look (\s -> p `mplus` f s)++-- ---------------------------------------------------------------------------+-- The ReadP type++newtype Parser r s a = R ((a -> P s r) -> P s r)+type ReadP r a = Parser r Char a++-- Functor, Monad, MonadPlus++instance Functor (Parser r s) where+  fmap h (R f) = R (\k -> f (k . h))++instance Applicative (Parser r s) where+  pure x  = R (\k -> k x)+  (<*>) = ap++instance s ~ Char => Alternative (Parser r s) where+  empty = pfail+  (<|>) = (+++)++instance Monad (Parser r s) where+  return = pure+  R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))++#if !(MIN_VERSION_base(4,9,0))+  fail _ = R (const Fail)+#elif !(MIN_VERSION_base(4,13,0))+  fail = Fail.fail+#endif++instance Fail.MonadFail (Parser r s) where+  fail _    = R (const Fail)++instance s ~ Char => MonadPlus (Parser r s) where+  mzero = pfail+  mplus = (+++)++-- ---------------------------------------------------------------------------+-- Operations over P++final :: [(a,[s])] -> P s a+-- Maintains invariant for Final constructor+final [] = Fail+final r  = Final r++run :: P c a -> ([c] -> [(a, [c])])+run (Get f)      (c:s) = run (f c) s+run (Look f)     s     = run (f s) s+run (Result x p) s     = (x,s) : run p s+run (Final r)    _     = r+run _            _     = []++-- ---------------------------------------------------------------------------+-- Operations over ReadP++get :: ReadP r Char+-- ^ Consumes and returns the next character.+--   Fails if there is no input left.+get = R Get++look :: ReadP r String+-- ^ Look-ahead: returns the part of the input that is left, without+--   consuming it.+look = R Look++pfail :: ReadP r a+-- ^ Always fails.+pfail = R (const Fail)++eof :: ReadP r ()+-- ^ Succeeds iff we are at the end of input+eof = do { s <- look+         ; if null s then return ()+                     else pfail }++(+++) :: ReadP r a -> ReadP r a -> ReadP r a+-- ^ Symmetric choice.+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)++(<++) :: ReadP a a -> ReadP r a -> ReadP r a+-- ^ Local, exclusive, left-biased choice: If left parser+--   locally produces any result at all, then right parser is+--   not used.+R f <++ q =+  do s <- look+     probe (f return) s 0+ where+  probe (Get f')       (c:s) n = probe (f' c) s (n+1 :: Int)+  probe (Look f')      s     n = probe (f' s) s n+  probe p@(Result _ _) _     n = discard n >> R (p >>=)+  probe (Final r)      _     _ = R (Final r >>=)+  probe _              _     _ = q++  discard 0 = return ()+  discard n  = get >> discard (n-1 :: Int)++gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)+-- ^ Transforms a parser into one that does the same, but+--   in addition returns the exact characters read.+--   IMPORTANT NOTE: 'gather' gives a runtime error if its first argument+--   is built using any occurrences of readS_to_P.+gather (R m) =+  R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))+ where+  gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))+  gath _ Fail         = Fail+  gath l (Look f)     = Look (gath l . f)+  gath l (Result k p) = k (l []) `mplus` gath l p+  gath _ (Final _)    = error "do not use readS_to_P in gather!"++-- ---------------------------------------------------------------------------+-- Derived operations++satisfy :: (Char -> Bool) -> ReadP r Char+-- ^ Consumes and returns the next character, if it satisfies the+--   specified predicate.+satisfy p = do c <- get; if p c then return c else pfail++char :: Char -> ReadP r Char+-- ^ Parses and returns the specified character.+char c = satisfy (c ==)++string :: String -> ReadP r String+-- ^ Parses and returns the specified string.+string this = do s <- look; scan this s+ where+  scan []     _               = return this+  scan (x:xs) (y:ys) | x == y = get >> scan xs ys+  scan _      _               = pfail++munch :: (Char -> Bool) -> ReadP r String+-- ^ Parses the first zero or more characters satisfying the predicate.+munch p =+  do s <- look+     scan s+ where+  scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)+  scan _            = do return ""++munch1 :: (Char -> Bool) -> ReadP r String+-- ^ Parses the first one or more characters satisfying the predicate.+munch1 p =+  do c <- get+     if p c then do s <- munch p; return (c:s)+            else pfail++choice :: [ReadP r a] -> ReadP r a+-- ^ Combines all parsers in the specified list.+choice []     = pfail+choice [p]    = p+choice (p:ps) = p +++ choice ps++skipSpaces :: ReadP r ()+-- ^ Skips all whitespace.+skipSpaces =+  do s <- look+     skip s+ where+  skip (c:s) | isSpace c = do _ <- get; skip s+  skip _                 = do return ()++skipSpaces1 :: ReadP r ()+-- ^ Like 'skipSpaces' but succeeds only if there is at least one+-- whitespace character to skip.+skipSpaces1 = satisfy isSpace >> skipSpaces++count :: Int -> ReadP r a -> ReadP r [a]+-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of+--   results is returned.+count n p = replicateM n p++between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a+-- ^ @ between open close p @ parses @open@, followed by @p@ and finally+--   @close@. Only the value of @p@ is returned.+between open close p = do _ <- open+                          x <- p+                          _ <- close+                          return x++option :: a -> ReadP r a -> ReadP r a+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming+--   any input.+option x p = p +++ return x++optional :: ReadP r a -> ReadP r ()+-- ^ @optional p@ optionally parses @p@ and always returns @()@.+optional p = (p >> return ()) +++ return ()++many :: ReadP r a -> ReadP r [a]+-- ^ Parses zero or more occurrences of the given parser.+many p = return [] +++ many1 p++many1 :: ReadP r a -> ReadP r [a]+-- ^ Parses one or more occurrences of the given parser.+many1 p = liftM2 (:) p (many p)++skipMany :: ReadP r a -> ReadP r ()+-- ^ Like 'many', but discards the result.+skipMany p = many p >> return ()++skipMany1 :: ReadP r a -> ReadP r ()+-- ^ Like 'many1', but discards the result.+skipMany1 p = p >> skipMany p++sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]+-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.+--   Returns a list of values returned by @p@.+sepBy p sep = sepBy1 p sep +++ return []++sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]+-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.+--   Returns a list of values returned by @p@.+sepBy1 p sep = liftM2 (:) p (many (sep >> p))++endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]+-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended+--   by @sep@.+endBy p sep = many (do x <- p ; _ <- sep ; return x)++endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]+-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended+--   by @sep@.+endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)++chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a+-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.+--   Returns a value produced by a /right/ associative application of all+--   functions returned by @op@. If there are no occurrences of @p@, @x@ is+--   returned.+chainr p op x = chainr1 p op +++ return x++chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a+-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.+--   Returns a value produced by a /left/ associative application of all+--   functions returned by @op@. If there are no occurrences of @p@, @x@ is+--   returned.+chainl p op x = chainl1 p op +++ return x++chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a+-- ^ Like 'chainr', but parses one or more occurrences of @p@.+chainr1 p op = scan+  where scan   = p >>= rest+        rest x = do f <- op+                    y <- scan+                    return (f x y)+                 +++ return x++chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a+-- ^ Like 'chainl', but parses one or more occurrences of @p@.+chainl1 p op = p >>= rest+  where rest x = do f <- op+                    y <- p+                    rest (f x y)+                 +++ return x++manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]+-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@+--   succeeds. Returns a list of values returned by @p@.+manyTill p end = scan+  where scan = (end >> return []) <++ (liftM2 (:) p scan)++-- ---------------------------------------------------------------------------+-- Converting between ReadP and Read++readP_to_S :: ReadP a a -> ReadS a+-- ^ Converts a parser into a Haskell ReadS-style function.+--   This is the main way in which you can \"run\" a 'ReadP' parser:+--   the expanded type is+-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @+readP_to_S (R f) = run (f return)++readS_to_P :: ReadS a -> ReadP r a+-- ^ Converts a Haskell ReadS-style function into a parser.+--   Warning: This introduces local backtracking in the resulting+--   parser, and therefore a possible inefficiency.+readS_to_P r =+  R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))++-------------------------------------------------------------------------------+-- ReadE+-------------------------------------------------------------------------------++readP_to_E :: (String -> String) -> ReadP a a -> ReadE a+readP_to_E err r =+    ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt+                         , all isSpace s ]+                    of [] -> Left (err txt)+                       (p:_) -> Right p
+ src/Distribution/Deprecated/ViewAsFieldDescr.hs view
@@ -0,0 +1,84 @@+module Distribution.Deprecated.ViewAsFieldDescr (+    viewAsFieldDescr+    ) where++import Distribution.Client.Compat.Prelude hiding (get)+import Prelude ()++import qualified Data.List.NonEmpty as NE+import Distribution.ReadE          (parsecToReadE)+import Distribution.Simple.Command+import Text.PrettyPrint            (cat, comma, punctuate, text)+import Text.PrettyPrint            as PP (empty)++import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError)++-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >+-- Choice > Opt) and consider only the first one.+viewAsFieldDescr :: OptionField a -> FieldDescr a+viewAsFieldDescr (OptionField _n []) =+  error "Distribution.command.viewAsFieldDescr: unexpected"+viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set++    where+      optDescr = head $ NE.sortBy cmp (d:|dd)++      cmp :: OptDescr a -> OptDescr a -> Ordering+      ReqArg{}    `cmp` ReqArg{}    = EQ+      ReqArg{}    `cmp` _           = GT+      BoolOpt{}   `cmp` ReqArg{}    = LT+      BoolOpt{}   `cmp` BoolOpt{}   = EQ+      BoolOpt{}   `cmp` _           = GT+      ChoiceOpt{} `cmp` ReqArg{}    = LT+      ChoiceOpt{} `cmp` BoolOpt{}   = LT+      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ+      ChoiceOpt{} `cmp` _           = GT+      OptArg{}    `cmp` OptArg{}    = EQ+      OptArg{}    `cmp` _           = LT++--    get :: a -> Doc+      get t = case optDescr of+        ReqArg _ _ _ _ ppr ->+          (cat . punctuate comma . map text . ppr) t++        OptArg _ _ _ _ _ ppr ->+          case ppr t of []        -> PP.empty+                        (Nothing : _) -> text "True"+                        (Just a  : _) -> text a++        ChoiceOpt alts ->+          fromMaybe PP.empty $ listToMaybe+          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]++        BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t++--    set :: LineNo -> String -> a -> ParseResult a+      set line val a =+        case optDescr of+          ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val+                                     -- We parse for a single value instead of a+                                     -- list, as one can't really implement+                                     -- parseList :: ReadE a -> ReadE [a] with+                                     -- the current ReadE definition+          ChoiceOpt{}             ->+            case getChoiceByLongFlag optDescr val of+              Just f -> return (f a)+              _      -> syntaxError line val++          BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val++          OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE val+                                     -- Optional arguments are parsed just like+                                     -- required arguments here; we don't+                                     -- provide a method to set an OptArg field+                                     -- to the default value.++getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a)+getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe+                                           [ set | (_,(_sf,lf:_), set, _) <- alts+                                                 , lf == val]++getChoiceByLongFlag _ _ =+  error "Distribution.command.getChoiceByLongFlag: expected a choice option"++
− tests/IntegrationTests2/build/keep-going/cabal.project 
@@ -1,1 +0,0 @@-packages: p q
− tests/IntegrationTests2/build/keep-going/p/P.hs 
@@ -1,4 +0,0 @@-module P where--p :: Int-p = this_is_not_expected_to_compile
− tests/IntegrationTests2/build/keep-going/p/p.cabal 
@@ -1,8 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: P-  build-depends: base
− tests/IntegrationTests2/build/keep-going/q/Q.hs 
@@ -1,4 +0,0 @@-module Q where--q :: Int-q = 42
− tests/IntegrationTests2/build/keep-going/q/q.cabal 
@@ -1,9 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  build-depends: base-
− tests/IntegrationTests2/build/local-tarball/cabal.project 
@@ -1,2 +0,0 @@-packages: p-0.1.tar.gz-          q/
− tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz

binary file changed (319 → absent bytes)

− tests/IntegrationTests2/build/local-tarball/q/Q.hs 
@@ -1,5 +0,0 @@-module Q where--import P--q = p ++ " world"
− tests/IntegrationTests2/build/local-tarball/q/q.cabal 
@@ -1,8 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  build-depends: base, p
− tests/IntegrationTests2/build/setup-custom1/A.hs 
@@ -1,4 +0,0 @@-module A where--a :: Int-a = 42
− tests/IntegrationTests2/build/setup-custom1/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain >> writeFile "marker" "ok"
− tests/IntegrationTests2/build/setup-custom1/a.cabal 
@@ -1,13 +0,0 @@-name: a-version: 0.1-build-type: Custom-cabal-version: >= 1.10---- explicit setup deps:-custom-setup-  setup-depends: base, Cabal >= 1.18--library-  exposed-modules: A-  build-depends: base-  default-language: Haskell2010
− tests/IntegrationTests2/build/setup-custom2/A.hs 
@@ -1,4 +0,0 @@-module A where--a :: Int-a = 42
− tests/IntegrationTests2/build/setup-custom2/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain >> writeFile "marker" "ok"
− tests/IntegrationTests2/build/setup-custom2/a.cabal 
@@ -1,11 +0,0 @@-name: a-version: 0.1-build-type: Custom-cabal-version: >= 1.10---- no explicit setup deps--library-  exposed-modules: A-  build-depends: base-  default-language: Haskell2010
− tests/IntegrationTests2/build/setup-simple/A.hs 
@@ -1,4 +0,0 @@-module A where--a :: Int-a = 42
− tests/IntegrationTests2/build/setup-simple/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− tests/IntegrationTests2/build/setup-simple/a.cabal 
@@ -1,9 +0,0 @@-name: a-version: 0.1-build-type: Simple-cabal-version: >= 1.10--library-  exposed-modules: A-  build-depends: base-  default-language: Haskell2010
− tests/IntegrationTests2/exception/bad-config/cabal.project 
@@ -1,4 +0,0 @@-packages:--package foo-  ghc-location: bar
− tests/IntegrationTests2/exception/build/Main.hs 
@@ -1,1 +0,0 @@-main = thisNameDoesNotExist
− tests/IntegrationTests2/exception/build/a.cabal 
@@ -1,8 +0,0 @@-name: a-version: 1-build-type: Simple-cabal-version: >= 1.2--executable a-  main-is: Main.hs-  build-depends: base
− tests/IntegrationTests2/exception/configure/a.cabal 
@@ -1,9 +0,0 @@-name: a-version: 1-build-type: Simple--- This used to be a blank package with no components,--- but I refactored new-build so that if a package has--- no buildable components, we skip configuring it.--- So put in a (failing) component so that we try to--- configure.-executable a
− tests/IntegrationTests2/exception/no-pkg/empty.in 
@@ -1,1 +0,0 @@-this is just here to ensure the source control creates the dir
− tests/IntegrationTests2/exception/no-pkg2/cabal.project 
@@ -1,1 +0,0 @@-packages: ./
− tests/IntegrationTests2/regression/3324/cabal.project 
@@ -1,1 +0,0 @@-packages: p q
− tests/IntegrationTests2/regression/3324/p/P.hs 
@@ -1,4 +0,0 @@-module P where--p :: Int-p = 42
− tests/IntegrationTests2/regression/3324/p/p.cabal 
@@ -1,8 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: P-  build-depends: base
− tests/IntegrationTests2/regression/3324/q/Q.hs 
@@ -1,6 +0,0 @@-module Q where--import P--q :: Int-q = p
− tests/IntegrationTests2/regression/3324/q/q.cabal 
@@ -1,9 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  build-depends: base-  -- missing a dep on p here, so expect failure initially
− tests/IntegrationTests2/targets/all-disabled/cabal.project 
@@ -1,1 +0,0 @@-packages: ./
− tests/IntegrationTests2/targets/all-disabled/p.cabal 
@@ -1,23 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  build-depends: base, filepath-  buildable: False--executable buildable-false-  main-is: Main.hs-  buildable: False--test-suite solver-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-  build-depends: a-package-that-does-not-exist--benchmark user-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-
− tests/IntegrationTests2/targets/benchmarks-disabled/cabal.project 
@@ -1,1 +0,0 @@-packages: ./ ./q/
− tests/IntegrationTests2/targets/benchmarks-disabled/p.cabal 
@@ -1,15 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.10--benchmark solver-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-  build-depends: a-package-that-does-not-exist--benchmark user-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-  build-depends: base-
− tests/IntegrationTests2/targets/benchmarks-disabled/q/q.cabal 
@@ -1,10 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.10--benchmark buildable-false-  type: exitcode-stdio-1.0-  main-is: Main.hs-  buildable: False-
− tests/IntegrationTests2/targets/complex/cabal.project 
@@ -1,1 +0,0 @@-packages: q/
− tests/IntegrationTests2/targets/complex/q/Q.hs 
− tests/IntegrationTests2/targets/complex/q/q.cabal 
@@ -1,23 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  -- we rely that filepath has filepath-tests component-  build-depends: base, filepath >=1.4.0.0--executable buildable-false-  main-is: Main.hs-  buildable: False--test-suite solver-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-  build-depends: a-package-that-does-not-exist--benchmark user-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-
− tests/IntegrationTests2/targets/empty-pkg/cabal.project 
@@ -1,1 +0,0 @@-packages: ./
− tests/IntegrationTests2/targets/empty-pkg/p.cabal 
@@ -1,5 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2-
− tests/IntegrationTests2/targets/empty/cabal.project 
@@ -1,1 +0,0 @@-packages:
− tests/IntegrationTests2/targets/empty/foo.hs 
− tests/IntegrationTests2/targets/exes-disabled/cabal.project 
@@ -1,1 +0,0 @@-packages: p/ q/
− tests/IntegrationTests2/targets/exes-disabled/p/p.cabal 
@@ -1,9 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--executable p-  main-is: P.hs-  build-depends: base-  buildable: False
− tests/IntegrationTests2/targets/exes-disabled/q/q.cabal 
@@ -1,9 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--executable q-  main-is: Q.hs-  build-depends: base-  buildable: False
− tests/IntegrationTests2/targets/lib-only/p.cabal 
@@ -1,8 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: P-  build-depends: base
− tests/IntegrationTests2/targets/libs-disabled/cabal.project 
@@ -1,1 +0,0 @@-packages: p/ q/
− tests/IntegrationTests2/targets/libs-disabled/p/p.cabal 
@@ -1,9 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: P-  build-depends: base-  buildable: False
− tests/IntegrationTests2/targets/libs-disabled/q/q.cabal 
@@ -1,9 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  build-depends: base-  buildable: False
− tests/IntegrationTests2/targets/multiple-exes/cabal.project 
@@ -1,1 +0,0 @@-packages: ./
− tests/IntegrationTests2/targets/multiple-exes/p.cabal 
@@ -1,12 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.10--executable p1-  main-is:  P1.hs-  build-depends: base--executable p2-  main-is:  P2.hs-  build-depends: base
− tests/IntegrationTests2/targets/multiple-libs/cabal.project 
@@ -1,1 +0,0 @@-packages: p/ q/
− tests/IntegrationTests2/targets/multiple-libs/p/p.cabal 
@@ -1,8 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: P-  build-depends: base
− tests/IntegrationTests2/targets/multiple-libs/q/q.cabal 
@@ -1,8 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: Q-  build-depends: base
− tests/IntegrationTests2/targets/multiple-tests/cabal.project 
@@ -1,1 +0,0 @@-packages: ./
− tests/IntegrationTests2/targets/multiple-tests/p.cabal 
@@ -1,14 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.10--test-suite p1-  type: exitcode-stdio-1.0-  main-is:  P1.hs-  build-depends: base--test-suite p2-  type: exitcode-stdio-1.0-  main-is:  P2.hs-  build-depends: base
− tests/IntegrationTests2/targets/simple/P.hs 
− tests/IntegrationTests2/targets/simple/app/Main.hs 
− tests/IntegrationTests2/targets/simple/cabal.project 
@@ -1,1 +0,0 @@-packages: ./ q/
− tests/IntegrationTests2/targets/simple/p.cabal 
@@ -1,17 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: P-  build-depends: base--executable pexe-  main-is: Main.hs-  other-modules: PMain--executable ppexe-  main-is: Main.hs-  hs-source-dirs: app-  other-modules: PMain
− tests/IntegrationTests2/targets/simple/q/Q.hs 
− tests/IntegrationTests2/targets/simple/q/QQ.hs 
− tests/IntegrationTests2/targets/simple/q/q.cabal 
@@ -1,13 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.2--library-  exposed-modules: QQ-  other-modules: Q-  build-depends: base--executable qexe-  main-is: Main.hs-  other-modules: QMain
− tests/IntegrationTests2/targets/test-only/p.cabal 
@@ -1,9 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.2--test-suite pexe-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules: PMain
− tests/IntegrationTests2/targets/tests-disabled/cabal.project 
@@ -1,1 +0,0 @@-packages: ./ ./q/
− tests/IntegrationTests2/targets/tests-disabled/p.cabal 
@@ -1,15 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.10--test-suite solver-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-  build-depends: a-package-that-does-not-exist--test-suite user-disabled-  type: exitcode-stdio-1.0-  main-is: Test.hs-  build-depends: base-
− tests/IntegrationTests2/targets/tests-disabled/q/q.cabal 
@@ -1,10 +0,0 @@-name: q-version: 0.1-build-type: Simple-cabal-version: >= 1.10--test-suite buildable-false-  type: exitcode-stdio-1.0-  main-is: Main.hs-  buildable: False-
− tests/IntegrationTests2/targets/variety/cabal.project 
@@ -1,1 +0,0 @@-packages: ./
− tests/IntegrationTests2/targets/variety/p.cabal 
@@ -1,27 +0,0 @@-name: p-version: 0.1-build-type: Simple-cabal-version: >= 1.10--library-  exposed-modules: P-  build-depends: base--foreign-library libp-  type: native-shared-  other-modules: FLib--executable an-exe-  main-is: Main.hs-  other-modules: AModule--test-suite a-testsuite-  type: exitcode-stdio-1.0-  main-is: Test.hs-  other-modules: AModule  --benchmark a-benchmark-  type: exitcode-stdio-1.0-  main-is: Test.hs-  other-modules: AModule-